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Abstract 


This  technical  note  contains  the  source  code  for  the  first  level 
ocean  simulation  model  and  associated  test  and  display  programs. 
This  model  provides  simulations  of  internal  wave  activity  based  on 
average  oceanographic  conditions  at  a  given  location.  The  code  is 
written  in  FORTRAN  77  and  should  be  easily  ported  to  a  wide  variety 
of  computers  and  operating  systems.  This  technical  note  is  intended 
primarily  for  persons  implementing  and/or  modifying  the  code  on 
their  own  systems. 
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Ocean  Simulation  Model  for  Internal  Waves 
Computer  Source  Code 


Introduction 


The  computer  code  contained  in  this  technical  note  is  provided  as 
a  supplement  to  NOARL  Report  10,  "Ocean  Simulation  Model  for 
Internal  Waves."  The  philosophy  and  algorithms  used  in  the  code  are 
documented  in  that  report. 

This  technical  note  is  primarily  intended  to  provide  a  permanent 
record  of  the  source  code  and  a  reference  for  anyone  who  wishes  to 
implement  or  modify  this  code.  The  code  can  only  run  with  a  file 
containing  the  Levitus  5*  climatic  oceanographic  data  base.  This 
file  and  the  source  code  can  be  obtained  on  an  ASCII  tape  or  in 
VAX  BACKUP  format  from  NOARL,  Code  331.  To  obtain  this  tape,  a 
request  should  be  submitted  to 

Commanding  officer 
Attn:  Code  331 

Naval  Oceanographic  and  Atmospheric  Research  Laboratory 
Stennis  Space  Center,  MS  39529-5004. 
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*********************************************************************** 

* 

PROGRAM  M0DEL1  * 

* 

PURPOSE  FIRST  LEVEL  OCEAN  SIMULATION  MODEL.  * 

This  model  utilizes  a  coarse  oceanographic  data  base  * 
to  define  the  stratification.  The  variability  is  * 

introduced  through  advecting  the  fields  of  temperature  * 
and  salinity  by  vertical  internal  wave  motions  at  * 

given  positions  and  times,  based  on  a  Garrett-Munk  * 

model.  * 

* 

CURRENT  DATE  03/23/89  * 

★ 

AUTHOR ( S )  K . D •  Saunders  (NOARL)  * 

* 

★ 

* 

* 

★ 

★ 

*********************************************************************** 


noononnonooonoooonooonoooo 


INPUT 


UNIT  FILE 

5  SYS$ INPUT 


10 


LEVITUS.DAT 


DATA 


*  *  *  * 
* 
* 

_ * 

* 

_ ★ 


«  Ephemeral  input  file  - 

keyboard  » 

★ 

* 

1.  Starting  Latitude 

(decimal  °) 

* 

2.  Starting  Longitude 

(decimal  0 ) 

* 

3.  Direction  of  section 

(  0  from  north) 

* 

4.  Max  Range  (xmax) 

(  km  ) 

* 

5.  Max  Depth  (zraax) 

(  m  ) 

* 

6.  Delta  x 

(  km  ) 

* 

7.  Delta  z 

(  m  ) 

★ 

8.  Max  time 

(  s  ) 

* 

9.  Delta  time 

(  s  ) 

it 

* 

«  DIRECT  ACCESS* 

★ 

* 

Base  Temperature  and  Salinity  Profiles  needed 
define  the  field  of  Brunt-VaisSla  frequencies 
along  the  section. 


★ 

to* 

★ 

* 

* 


nnnonnnnnnnnonooonooonnoononnnnnooooooonnonnno 


★ 


OUTPUT 


Unit  FILE  DATA 


6 

SYSSOUTPUT 

«  ephemeral  file  » 

1.  Diagnostic  information 

11 

DIAGNOSTICS. LIS 

«  ASCII  file  * 

1.  Diagnostic  information 

12 

MODELl.DAT 

«  Direct/Unformatted* 

1.  Displacement  fields 

2.  Modified  Temperature  fields 

3.  Modified  Salinity  fields 

4.  Sound  velocity  fields 

(m) 

(  °C) 

(psu) 

(m/s) 

13 

MODEL1 .AUX 

«  ASCII  » 

Defining  Parameters  (labled) 

14 

MODELl . UV 

«  DIRECT  * 

1.  U  velocity  field  (m/s) 

2.  V  velocity  field  (m/s) 

3.  W  velocity  field  (m/s) 

15 

MODEL1.EIG 

«  DIRECT  » 

1.  Modal  Eigenvalues  and  Eigenfunctions  for 

W{  j  ,  z , x ) , k ( j , x ) 

16 

MODELl .CTL 

«  DIRECT  » 

1.  Control  information  relating 
eigenmode/eigenvalue  control 

to  restart  and 
and  use 

* 

* 

* 

★ 

* 

it 

it 

it 

★ 

it 

* 

* 

it 

it 

it 

* 

* 

* 

it 

it 

it 

it 

it 

it 

it 

it 

it 

★ 

★ 

★ 

★ 

★ 

* 

* 

* 

★ 

it 

it 

★ 

★ 

★ 


20  DEBUG.DAT 


«  ASCII  » 


* 

★ 


1.  DEBUGGING  TOOL  * 

★ 


nnnnnonnonooonnnnnoonoonnnnnnnooriononnnon 


NOTES 

1.  The  following  assumptions  are  made  for  this  first  level 
model : 

a  no  mean  currents  are  assumed. 

(this  restriction  will  be  relaxed  in  later  versions) 

a  only  the  internal  wave  part  of  the  spectrum  (including  the  M2 
tidal  contribution)  affects  the  fields  of  temperature  and 
salinity. 

(this  restriction  will  be  relaxed  in  later  versions) 

a  the  temperature  and  salinity  fields  are  initially  defined 
based  on  the  Levitus  5°  data  base  averages. 

(this  restriction  will  be  relaxed  in  later  versions) 

a  if  the  BV  frequency  is  imaginary,  it  is  set  to  zero  in  the 
mode  calculations. 

a  the  internal  wave  field  does  not  affect  the  modes  for  t  >  0 
(this  restriction  may  be  relaxed  in  later  versions) 

2.  The  profile  input  section  is  derived  from  programs  written 
by  William  Teague,  NOARL,  Code  331  in  conjunction  with  the 
MOODS  data  base  project. 

3.  The  internal  wave  simulation  section  was  originially  derived 
from  programs  written  by  Dr.  David  Rubenstein  ,  SAIC,  but 
which  have  been  since  extensively  modified  at  NOARL. 

4.  Record  lengths  differ  on  the  VAX  and  the  CONVEX.  An 
INTEGER* 4  variable,  RECCTL ,  addresses  this  difference. 

For  the  VAX,  RECCTL  -  1 

For  the  CONVEX,  RECCTL  -  4 


noonnnonoonnnnnnoonnnoonnoonononononooononnooonnnnnno 


*********************************************************************** 

★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★A**** 

STRUCTURE 

CONTROL_INPUT 

EIG_CONTROL 

I 

PROFILE_INPUT 

I 

I NT_WAVE_S I MULAT I ON 
(TIME  LOOP) 

(X  -  LOOP) 

DISPLACE 

PROFILE_CALC 

(OUTPUT  — >  MODELl.DAT) 

(END  ZLOOP) 

(END  X  -  LOOP) 

(END  TIME  -  LOOP) 

*********************************************************************** 

*********************************************************************** 

PROGRAM  LAYERING 

MAIN 


CONTROL_INPUT  PROFILE  INPUT  INT  WAVE  SIMULATION 

II  I 

EIG  CONTROL 


LINT  INTRPL  |  DIST 

I 

BVFREQ 


MODESUB 


TURN  NUMEROV  INTERP  AVGINT 


nnooooonononononnonooooooonoooononnnnnnonnonnono 


*********************************************************************** 

DEVELOPMENT  STATUS  and  HISTORY 


ROUTINE  DATE  STATUS 


* 


MAIN 

10/25/88 

Written 

* 

* 

CONTROL_INPUT 

10/25/88 

Written 

* 

* 

10/26/88 

Implicit  NONE  added 

* 

* 

11/18/88 

Added  File  for  U,V  output  - 

* 

unit  14 

* 

* 

EIG_CONTROL 

2/8/89 

Begun 

* 

* 

PROFI LE_INPUT 

10/25/88 

Partially  coded  and  tested 

* 

* 

10/26/88 

Profile  Interpolation  added 

* 

Implicit  NONE  added 

* 

BV  Calculations  added 

★ 

Diagnostic  output  file  added 

* 

* 

11/15/88 

Compute  min-max  BV  frequency 

* 

* 

LINT 

10/25/88 

Existed  -  modfied  to  include 

* 

end  points. 

* 

* 

10/26/88 

Implicit  NONE  added 

* 

* 

INTRPL 

- 

KDS  LIBRARY  ROUTINE 

* 

* 

DIST 

- 

KDS  PROGRAM  BASE 

* 

* 

10/26/88 

Documentation  improved. 

* 

Implicit  NONE  added 

* 

BVFREQ 

- 

WHOI  LIBRARY  ROUTINE 

* 

* 

10/26/88 

Documentation  improved 

* 

Implicit  NONE  added 

* 

* 

I NT_WAVE_S I MULAT I ON 

10/25/88 

«  Skeleton  » 

* 

* 

10/26/88 

Coded  -  testing  in  progress 

* 

nnnonnonononnoooonooooooononnoooonnnonnonoonnnnooooon 


DISPLACE 


SZ 


10/26/88 

10/27/88 


11/3/88 

11/8/88 


11/15/88 

11/16/88 

11/18/88 

01/17/89 

02/03/89 


02/06/89 

03/02/89 

10/25/88 

11/8/88 

02/06/89 


*Rubenstein  code 

Single  profile  per  call  set  up 
Reinitialization  of  variables 
before  call  to  MODESUB 
Added  3  parameters  to 
sequence:  ix,  nbvmax,nxmax 

Added  NDIR  random  directions 
for  each  mode  and  frequency 
contribution  in  isotropic  case 

Added  random  phase  to  each 
contribution  from  a  direction 
frequency  and  mode 

jstar  set  to  3  to  agree  with 
GM  spectrum:  p57,  Flatte 

Use  fixed  frequencies  for  each 
profile.  This  will  help  in 
improving  eigenvalue  estimates 

Changed  weighting  of  each 
directional  component  from 
1/NDIR  to  1/sqrt ( NDIR ) 

Added  U , V  calculations  and  file 

M2  Tidal  Component  added 

DF  replaced  by  sqrt(DF)  in  the 
simulation  of  integration  over 
frequency. 

Radian/sec  frequency  replaced 
cph  frequency  in  integration 

ZD,U,V,  rederived  from  W 

Logarithmic  frequencies  steps 
introduced . 

*Rubenstein  code 

Summation  of  H(j)  changed  to  use 
all  the  j,  not  just  the  odd 
modes 

Scaling  modified  to  reflect  the 
variation  in  the  BV  profile. 


nnnonnnnnonnonnooonnonnonnoo 


MODESUB  10/26/88  *Rubenstein  code  * 

★ 

11/15/88  Modified  to  use  previous  k's  * 

as  starting  points  for  next  * 
calculations  * 

* 


02/03/89 

Normalization  modified  to  create* 
orthonormal  eigenmodes.  * 

TURN 

10/25/88 

*Rubenstein  code  * 

NUMEROV 

10/25/88 

*Rubenstein  code  * 

INTERP 

10/25/88 

*Rubenstein  code  * 

•10/27/88 

Modified  array  declarations  to  * 
variable  dimensions  * 

AVGINT 

10/25/88 

*Rubenstein  code  * 

PROFILE_CALC 

10/26/88 

«  Skeleton  »  * 

10/27/88 

Coded  -  testing  in  progress  * 

★ 

* 

* 


IMPLICIT  NONE 


CHARACTER*8  TIMEBUFF 

CHARACTER*9  DATEBUFF 


REAL 


TTTO , TTTl , DTTT , DTTl 


INCLUDE  ' MODELl . INC ' 


CALL  CONTROL_INPUT 
CALL  PROFILE_INPUT 
CALL  INT  WAVE  SIMULATION 


STOP  '  NORMAL  END  OF  PROGRAM  REACHED' 
END 


ooonoononnnonnooonnoonooonoooonnooooon 


SUBROUTINE 


CONTROL  INPUT 


* 


PROGRAM  CONTROL  INPUT 


PURPOSE 


HISTORY 
AUTHOR ( S ) 


Reads  in  control  data 
10  terminal  files  opened 

Auxilliary  Latitude  and  Longitude  computed 
10/25/88  1.  Coding  begun. 

K.D.  Saunders  (NOARL) 


* 

* 

* 

* 

* 

* 

★ 

* 

* 

* 


INPUT 


* 

* 


FILE 

SYS$INPUT 


DATA  * 


1. 

Starting  Latitude 

( decimal 

8) 

★ 

2. 

Starting  Longitude 

( decimal 

°) 

* 

3. 

Direction  of  section 

(  0  from 

north ) 

* 

4. 

Max  Range  (xmax) 

(  km  ) 

* 

5. 

Max  Depth  ( zmax { 

(  m  ) 

* 

6. 

Delta  x 

(  km  ) 

★ 

7. 

Delta  z 

(  m  ) 

★ 

8. 

Max  time 

(  s  ) 

* 

9. 

Delta  time 

(  s  ) 

★ 

* 


OUTPUT 


FILE 


SYS$OUTPUT 


DATA 

1.  Diagnostic  information 

1.  All  output  is  passed  through  named  common 


* 

* 

* 

* 

* 

* 

* 


COMMONS 


noon 


IMPLICIT  NONE 

CHARACTER*8 
CHARACTERS 
CHARACTER* 3 

INTEGER 
INTEGER 
INTEGER  ITMP 

REAL 

INCLUDE 

LOGICAL  RESTART 


TIMEBUFF 

DATEBUFF 

ANS 

IANG , NT  TMP 
NDIR,ITtf,NT  DUM 


SINE, COSE 
' MODELl . INC ' 


COMMON  /DIR/  NDIR , ITO 

COMMON  /EIG_COM/  RESTART 

OPEN  (  FILE-TERMINAL_INPUT ,  UN  IT*  5  ,  STATUS*  '  UNKNOWN '  ,  DISP- '  DELETE '  ) 
OPEN  ( FILE«TERMINAL_OUT  , UNIT-6 , STATUS- ' UNKNOWN DI SP- ' DELETE ' ) 
OPEN  ( FILE* ' DIAGNOSTICS .LIS' , UNIT-1 1 , STATUS- ' NEW ' , DISP- 'KEEP' ) 
OPEN  ( FILE- ' DEBUG . DAT ' , UNI T-2 0 , STATUS-' NEW' ,DISP-'KEEP' ) 


WRITE ( * , * )  '  RESTART  -  ',  RESTART 

CALL  EIG_CONTROL 

WRITE (  *  ,  *  )  '  RESTART  -  ',  RESTART 

IF (.NOT.  RESTART)  THEN 


WRITE ( 6 , 100 ) 

READ ( 5 , * )  LAT, LON, AZIMUTH 
WRITE(6,105) 

READ (5,1)  SEASON 
WRITE ( 6 , 110 ) 

READ( 5 , * )  XMAX , DX , ZMAX , DZ , TMAX , DT 

WRITE( 6,160) 

READ ( 5 , * )  NDIR 
WRITE(6,200) 

READ ( 5 , * )  NEIG,NMODES ,NF 
WRITE (6,210) 

READ (5,1)  ANS 
I F (  ANS  .EQ.  'YES')  THEN 
GM_PROF  -  .TRUE. 

ELSE 

GM_PROF  -  .FALSE. 

END  IF 

I F (  NEIG  .EQ.  0)  NEIG  -  1000 

I F (  NF  .EQ.  0)  NF  -  8 

I F (  NMODES  .EQ.  0)  NMODES  -  5 


*  Read  in  control 

*  data 


WRITE ( 6 , 220 ) 

READ (5,1)  ANS 
I F (  ANS  .EQ.  'YES')  THEN 
TIDES  -  .TRUE. 


ELSE 


TIDES 


.FALSE. 


noon  nnno  nnooo  ooooo 


END  IF 


I  F  ( 

NDIR  .GT. 

30) 

NDIF 

.  . 

NT 

-  TMAX/DT 

+  1 

NX 

-  XMAX/DX 

+  1 

I F  ( 

NX 

.GT.  MAX) 

THEN 

NX  - 

MAX 

DX  - 

XMAX/ (NX- 

1) 

WRITE 

:(  6, 

140) 

NX 

WRITE 

idl. 

140) 

NX 

END 

IF 

NZ 

-  ZMAX/DZ 

+  1 

I F  ( 

NZ 

.GT.  MAX) 

THEN 

NZ  - 

MAX 

DZ  - 

Z  MAX/ ( N  Z - 

1) 

WRITE 

;(  6, 

150) 

NZ 

WRITE 

:(U, 

150) 

NZ 

END 

IF 

WRITE ( ] 

.1,120) 

LAT 

,  LON , 

az; 

WRITE ( I 

.1,170) 

DT, 

DX ,  DZ 

WRITE ( 

6,120) 

LAT 

,  LON , 

az: 

30 


XMAX 

XMAX 


ZMAX ,  TMAX ,  NX ,  N2 
ZMAX,TMAX,NX,NZ 


NT , NDIR 
NT , NDIR 


************************** 

*  Compute  nearest  pos.  * 

*  that  is  5°  away  from* 

*  from  the  input  pos.  * 
************************** 


*********************** 

*  Reduce  azimuth  to  * 

*  nearest  multiple  of  * 

*  45°  * 

*********************** 

I F (  AZIMUTH  .LT.  0)  AZIMUTH  -  AZIMUTH  +  360.0 
IANG  -  AZIMUTH  +22.5 
IANG  -  45* ( IANG/45 ) 

I F (  IANG  .GE.  360)  IANG  -  0 

AZIMUTH  -  IANG 


SINE  -  SIND (AZIMUTH ) 

COSE  -  COSD( AZIMUTH) 

I F (  SINE  .NE.  0)  THEN 

SINE  -  SINE/ABS ( SINE) 

END  IF 

I F (  COSE  .NE.  0)  THEN 

COSE  -  COSE/ABS ( COSE ) 

END  IF 


************************* 

*  Locate  point  on  * 

*  edge  of  10°  square  * 
************************* 


*  Latl  and  lonl  used  * 

*  in  prof ile_input  * 


n  n  o  n  n  n 


LATl  -  LAT  +  5 .  *C(*';E 
L0N1  -  LON  +  5 . *SINE 


WRITE ( 11,130 )  LAT, LON, LATl, LON1 , AZIMUTH 
WRI TE ( 6 , 1 3  0 )  LAT , LON , LATl , LONl , AZ I MUTH 

****************************** 

*  DIFFERENT  RECORD  LENGTHS  * 

*  * 

*  For  CONVEX:  RECCTL  -  4  * 

*  For  VAX:  RECCTL  -  1  * 

****************************** 


RECCTL  -  1 
C  RECCTL  -  4 

OPEN  ( FILE-'MODELl .DAT' , UNI T-12 , STATUS- ' NEW' ,DISP-'KEEP' , 

1  ACCESS- 'DIRECT' , FORM- ' UNFORMATTED ' , RECL-RECCTL*NZ*4 ) 

OPEN  ( FILE-'MODELl .AUX' , UNIT-1 3 , STATUS- ' NEW ' ,DISP-'KEEP' ) 
OPEN  ( FILE-'MODELl .UV' , UNIT-14 , STATUS- 'NEW' ,DISP-'KEEP' , 

1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , RECL- 3 *NZ * RECCTL ) 

itmp  «  NZ+1 

OPEN  ( FILE-'MODELl .EIG'  , UNIT-1 5 , STATUS- ' NEW' ,DISP-'KEEP' , 

1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , RECL- i tmp* RECCTL ) 

OPEN  ( FILE-'MODELl .CTL' , UNIT-16 , STATUS- ' NEW' ,DISP-'KEEP' , 

1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , RECL-5*RECCTL ) 


T  -  0 

WRITE ( 16 , REC— 1 )  NX,DX,XMAX 
WRITE ( 16 , REC-2 )  NZ , DZ , ZMAX 
WRITE ( 16 ,REC-3 )  NT , DT , TMAX 

WRITE ( 16 , REC— 4 )  LAT, LON, LATl , LONl , AZIMUTH 
WRITE ( 16 , REC- 5 )  T,0,NDIR 
WRITE (16, REC— 6 )  NEIG , NMODES , NF 

ELSE 

OPEN  ( FILE-'MODELl. DAT' , UNIT-1 2 , STATUS- ' OLD ' ,DISP«'KEEP' , 
1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , RECL-4*NZ*RECCTL ) 

OPEN  ( FILE-'MODELl .AUX' , UNIT-1 3 , STATUS- ' OLD ' ,DISP-'KEEP'  ) 
OPEN  (FILE-'MODELl. UV' , UNIT-1 4 , STATUS- ' OLD ' ,DISP-'KEEP' , 

1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , RECL-3 *NZ*RECCTL ) 

ITMP  -  NZ+1 

OPEN  ( FILE-'MODELl . EIG' , UNIT-1 5 , STATUS- ' OLD ' ,DISP-'KEEP' , 
1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , RECL- I TMP* RECCTL ) 

OPEN  ( FILE-'MODELl .CTL' , UNIT-16 , STATUS- ' OLD' ,DISP-'KEEP' , 
1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , RECL-5*RECCTL ) 


WRITE (6,190)  NT 
READ ( 5 , * )  NT_TMP 
I F (  NT_TMP  .GT.  NT  )  THEN 
NT  -  NT_TMP 

ELSE 

STOP  '  ****  MAX  TIME  STEPS  TOO  SMALL  ****' 

END  IF 

READ (16, REC- 3)  NT_DUM , DT , TMAX 
WRITE ( 16 , REC- 3 )  NT, DT, TMAX 

READ  ( 16 , REC-5 )  T,IT0,NDIR 
I F (  NDIR  .EQ.  0)  THEN 

WRITE ( * , * )  '  ENTER  NON-ZERO  VALUE  FOR  NDIR' 
READ (  ^  ,  *  )  NDIR 


WRITE  (16,REC-5)  T, ITO , NDIR 

END  IF 

READ ( 16 , REC-6 )  NEIG , NMODES , NF 
END  IF 


RETURN 


1 


FORMAT ( A ) 


100  FORMAT (  //'  ****a*******OCEAN  SIMULATION  MODEL*******************'/ 

1  '  VERSION  1.0  '/// 

2  '  Enter  latitude,  longitude  and  direction  of  section  in'/ 

3  '  decimal  degrees.  '//) 

105  FORMAT ( //'  Enter  season  (WINTER, SPRING, SUMMER  OR  FALL)'//) 

110  FORMAT { //  '  Enter  maximum  and  delta  ranges  in  km,  '/ 

1  '  maximum  and  delta  depths  in  m,  '/ 

2  '  maximum  and  delta  times  in  s  '//) 


120  FORMAT ( //  '  INPUT  DATA  '/'  ***********'// 

1  '  Latitude  -  ',£13.3/ 

2  '  Longitude  -  ',fl3.3/ 

3  '  Azimuth  »  ',fl3.3// 

4  '  Xmax  ■  ' , f 13 . 3/ 

5  '  Zmax  ■  ' , fl3 . 3/ 

6  '  Tmax  -  ' ,G13.3/ 

7  '  NX , NZ , NT , NDIR  -  ',  4i8//) 

130  FORMAT (//'  COMPUTED  VALUES  '// 

1  '  LAT  -  ' , FI  0 . 3 , '  LON  -  ',F10.3/ 

2  '  LATl  -  ' , F10 . 3  ,  '  LONl  *  ',F10.3/ 

3  '  Reduced  Azimuth  -  ',fl0.3//) 


140 

1 

FORMAT ( 

'  NX , DX  Have  been  redefined  to  conform  to  storage' 
'  requirements.'/'  NX  «  ',110/'  DX  -  ',G16.5//) 

150 

1 

FORMAT ( 

'  NZ,DZ  Have  been  redefined  to  conform  to  storage' 
'  requirements.'/'  NZ  -  ',110/'  DZ  «  ',G16.5//) 

160 

1 

FORMAT ( 

'  ENTER  THE  NUMBER  OF  DIRECTIONS  TO  USE  ', 

'IN  ISOTROPIC  CASE'/) 

170 

FORMAT ( 

'  DT , DX , DZ  -  ',  3F18.3///) 

190 

1 

FORMAT (  //'  THE  OLD  VALUE  FOR  NT  IS  ',  15/ 

'  ENTER  A  NEW  VALUE  FOR  NT  >  NT (OLD)  '/) 

200  FORMAT (  //'  ENTER  NEIG,  NMODES,  NF  ') 

210  FORMAT (  //'  DO  YOU  WANT  GENERIC  GARRET-MUNK  BVF  PROFILE  ?') 

220  t ORMAT (  //'  DO  YOU  WANT  M2  INTERNAL  TIDES  ?') 


END 


nnnnonnnno  oononnonnnnonnonooonnooo 


SUBROUTINE  EIG_CONTROL 

************************************************************************ 

* 

EIG_CONTROL  * 

* 

Checks  to  see  whether  a  restart  is  possible,  and,  if  so  * 
requests  information  relating  to  whether  it  is  desired.  * 
If  the  program  is  not  to  be  restarted,  the  old  files 
are  closed  and  new  ones  opened.  Otherwise,  the  old 
data  and  control  files  are  reused. 


SUBROUTINE 

PURPOSE 


Author 

History 


K.D.  Saunders 

2/8/89  -  Coding  begun 


* 
* 
* 
* 
* 
* 
* 
* 

* 

Notes  * 

* 

The  logical  variable,  RESTART  is  used  to  determine  whether  this  * 

is  a  restart  or  a  new  run.  It  will  also  be  used  in  determining  * 

whether  to  recompute  eigenfunctions  later  in  the  program.  * 

* 


CHARACTER* 80 

INTEGER 

INTEGER 

INTEGER 

LOGICAL 


QUERY, ANSWER 

DATRECL , EIGRECL , IDUM 

LENGl,LENG2 

NDIR, ITO 

RESTART, AUXEXIST, DATEXIST, CTLEXIST, EIGEXIST 


COMMON  /EIG_COM/  RESTART 

COMMON  /DIR/  NDIR, ITO 

INCLUDE  ' MODELl . INC ' 


***************************************** 

*  Test  to  see  if  the  Eigenfunction  * 

*  data  and  control  files  exist  and  are  * 

*  compatible  with  any  existing  version  * 

*  the  MODELl. AUX  file.  * 

*  * 

*  If  they  are,  query  to  see  if  a  restart* 

*  is  desired.  If  not,  close  all  the  * 

*  files  and  start  over.  * 

***************************************** 


RESTART 


.TRUE. 


INQUIRE (FILE-' MODELl .AUX' , EXI ST-AUXEXIST ) 

INQUIRE ( FILE* ' MODELl . DAT ' , EXI ST-DATEXI ST , RECL-lengl ) 
INQUIRE ( FILE- ' MODELl .EIG' , EXI ST-EIGEXI ST , RECL-leng2 ) 
INQUIRE ( FILE- ' MODELl . CTL ' , EXIST-CTLEXIST) 

DATRECL  -  lengl *RECCTL 
EIGRECL  -  leng2*RECCTL 

I F (  .NOT.  (AUXEXIST  .AND.  DATEXIST  .AND.  CTLEXIST  .AND. 
EIGEXIST)  )  THEN 

WRITE( * , * )  '  AUXEXIST  ',  AUXEXIST 
WRITE{ * , * )  '  DATEXIST  ',  DATEXIST 


WRITE (  *  ,  *  )  '  CTLEXIST  '.‘TLEXIST 
WRITE( *  ,  * )  •  EIGEXIST  EIGEXIST 

RESTART  -  .FALSE. 

ELSE 

OPEN {  UNIT-16, FILE-'MODELl.CTL' , STATUS- ' OLD ' , 

1  DI SP- ' KEEP ' ,ACCESS- ' DIRECT ' , RECL-5 *RECCTL ) 

READ( 16 , REC-1 )  NX,DX,XMAX 

READ( 16 , REC-2 )  NZ,DZ,ZMAX 

READ( 16 , REC-3 )  NT , DT , TMAX 

READ (16, REC- 4 )  LAT , LON , LATl , LONl , AZIMUTH 

READ{ 16 , REC-5 )  T, ITO ,NDIR 

READ ( 16 , REC- 6 )  NEIG, NMODES , NF 

CLOSE (  UNIT-16) 

I F (  DATRECL  .NE.  4*RECCTL*NZ)  THEN 
RESTART  -  .FALSE. 

WRITE ( * , * )  '  DATRECL  ', DATRECL , 4 *RECCTL*NZ 

END  IF 

I F (  EIGRECL  .NE.  4*(NZ+1))  THEN 
RESTART  -  .FALSE. 

WRITE ( * , * )  '  EIGRECL  EIGRECL , 4 *( NZ+1 ) 

END  IF 

IF  (  RESTART  )  THEN 
WRITE( 6,100) 

READ (5,1)  ANSWER 

IF  (  INDEX (ANSWER, 'YES' )  . NE .  0  .OR. 

1  INDEX( ANSWER, 'yes' )  .NE.  0)  THEN 

RESTART  -  .TRUE. 

ELSE 

RESTART  -  .FALSE. 

END  IF 
END  IF 

END  IF 
FORMAT ( A ) 

FORMAT (  '  DO  YOU  WANT  TO  RESTART  THE  PROGRAM  WHERE  IT', 

'  WAS  LEFT  OFF  ?  '// 

'  Answering  YES  will  restart  at  that  point  '/ 

'  Answering  NO  will  reinitialize  the  computation'//) 


RETURN 

END 


SUBROUTINE  PROFILE_INPUT 

IMPLICIT  NONE 
INCLUDE  ' MODELl . INC ' 


£************************************************************************ 
£********************************************★*************************** 
c  * 

C  PROGRAM  PROFILE_INPUT  * 

C  * 

C  PURPOSE  LOCATES  PROFILES  AT  LAT , LON , LATl , LONl  AND  READS  IN  THE  * 

C  TEMPERATURE  AND  SALINITY  PROFILES  AT  BOTH  LOCATIONS  FROM* 

C  LEVITUS  5°  DATABASE.  * 

C  * 

C  HISTORY  10/25/88  1.  Program  begun.  * 

C  * 

C  AUTHOR ( S )  K.D.  Saunders  (NOARL)  * 

C  * 

C  * 

£************************************************************************ 
£************************************************************************ 
c  * 

C  INPUT  * 

C  * 

C  All  input  is  via  named  common  * 

C  * 

c************************************************************************ 
c************************************************************************ 

c  * 

C  OUTPUT  * 

C  SYSSOUTPUT  Diagnostic  information  * 

C  * 

C  COMMONS  All  data  are  returned  via  named  common  * 

C  * 

£************************************************************************ 
c************************************************************************ 

c  * 

c  * 

C  NOTES  * 

c  ******* 

C  The  following  notes  are  from  the  comments  in  Wm.  Teague's  program  * 

C - * 

C  PROGRAM:  LEVFEB  * 

C  PURPOSE:  THIS  PROGRAM  READS  A  DIRECT  ACCESS  FILE  CREATED  BY  LEVRD  AND  * 

C  WRITES  AND  WRITES  THE  DATA  IN  VFEB  FORMAT.  THE  OUTPUT  GROUP  * 

C  CONSISTS  OF  30  DEPTH  LEVELS  WITH  DEPENDENT  VARIABLES  OF  * 

C  NO.  OF  TEMP  OBSERVATIONS,  MEAN  TEMP,  STANDARD  DEVIATION  OF  * 

C  TEMP,  NO.  OF  SAL  OBSERVATIONS,  MEAN  SAL,  AND  STANDARD  DEVIATION  * 

C  OF  SAL.  * 

C - * 

£*********************************************************★******************** 


INTEGER  ISHIF, 

1  IPOSLOOP , 

2  ISF, 

3  IREC 


REAL  D{ 180  )  , 

1  ZLEV ( 30 ) , 

2  T_TEMP (  300  )  , 

3  S  TEMP (  300  )  , 

4  PT2), 


naJ>vooo~ja\cn 


PAV, 

X_RATIO, 

D_PROFILES, 

E, 

RLAT, 

RLON , 

DIST, 

BVFRQ 


CHARACTER* 80  LEVFILE 


DATA  ZLEV/0,1 0,20, 30, 50, 75, 100, 12 5, 150, 200, 250, 300, 400, 500, 

1  600,700,800,900,1000,1100,1200,1300,1400,1500, 

2  1750,2000,2500,3000,3500,4000/ 


C 

c 

c 

c 


************************* 

*  OPEN  INPUT  FILE.  VAX  * 

*  FILE  SYSTEM  TO  BE  USED* 
************************* 

IF  (  RECCTL  .EQ.  1)  THEN 

LEVFILE  -  'MODELBASE? :LEVITUS .DAT' 

END  IF 


C 

C 

c 

c 


IF  (  RECCTL  .EQ.  4)  THEN 

LEVFILE  *  'LEVITUS.DAT' 

END  IF 


************************** 

*  OPEN  INPUT  FILE.  CONVEX* 

*  FILE  SYSTEM  TO  BE  USED  * 
************************** 


OPEN ( UNIT*1 0 , FI LE*LEVFI LE , 

&  ACCESS* ' DIRECT' , FORM* ' UNFORMATTED ' , STATUS* ' OLD ' , 
&  ERR*9091 ,RECL-180*RECCTL, READONLY) 


C 

C 

C 


C 


C 


C 


C 

C 


*  WINTER  -  FEB,  MAR,  APR  * 

*  -  USE  MID  MARCH  FOR  TIME  * 

*  IN  FDOC (1,1)  * 

IF  ( SEASON (1:2) . EQ . ' WI ' ) THEN 
ISHIF*0 

*  SPRING  -  MAY,  JUN,  JUL  * 

ELSE  IF  ( SEASON ( 1 : 2 ) . EQ . ' SP ' ) THEN 
ISHIF-36 

*  SUMMER  -  AUG,  SEP,  OCT  * 

ELSE  IF  ( SEASON ( 1 : 2 ) . EQ . ' SU ' ) THEN 
ISHIF-72 

*  FALL  -  NOV,  DEC,  JAN  * 

ELSE  IF  (SEASON(l:2) .EQ. 'FA' )THEN 
ISHIF-108 
ELS  £ 

*  USE  SUMMER  IF  SEASON  * 

*  NOT  CORRECTLY  SPECIFIED  * 

I SHI F  -  72 
END  IF 


DO  200  I POSLOOP  -  1,2 


I F ( I POSLOOP  .EQ.  1)  THEN 
RLAT  -  LAT 
RLON  -  LON 


nnnnn  onnn  non  non 


ELSE 


RLAT  -  LATl 
RLON  -  L0N1 

END  IF 

I F ( RLON . LT . 0 ) RLON-RLON+  360. 

RLAT-RLAT+90 . 

************************* 

*  CHECK  LAT  LON  VALUES  * 
************************* 

IF( ABS  ( RLON ) .GE.360. ) THEN 

WRITE( 6,*) 'LONGITUDE  NOT  BETWEEN  -180  AND  180  ' , RLON 
STOP  '  LONGITUDE  ERROR  -  PROGRAM  STOPPED  ' 

END  IF 

I F ( ABS ( RLAT ) .GT. 180 )THEN 

WRITE( 6,*) 'LATITUDE  NOT  BETWEEN  -90  AND  90  ' , RLAT 
STOP  '  LATITUDE  ERROR  -  PROGRAM  STOPPED' 

ENDIF 

************************************** 

*  COMPUTE  DIRECT  ACCESS  RECORD  NO.S  * 
************************************** 

I-RLON/5.+1. 

J-RLAT/5 .+1 . 

IREC-( 1-1 ) *144+J+ISHIF 

*********************************** 

*  READ  DATA  RECORD  -  NUMOBS,  TEMP,* 

*  SIGMA,  NUMOBS,  SAL,  SIGMA  * 

*********************************** 

READ( 1 0 , REC-IREC , ERR-9092 ) D 

K-0 

ISF-0 

WRITE( 11 , 130 ) 

DO  50  L-1,90,3 
K-K+l 

BUF( 1 )«ZLEV( K) 

BUF( 2 )«D( L) 

BUF ( 3 )-D( L+l  ) 

BUF(4)«D(L+2) 

BUF ( 5 )-D( L+90 ) 

BUF(6)-D(L+91) 

BUF ( 7 ) “D ( L+92 ) 

**************************** 

*  CHECK  FOR  0  OBSERVATIONS  * 

*  INSERT  MISSING  RECORD  * 

*  FLAG  THEN  -999.0  * 

**************************** 


I F ( BUF ( 2 ) . LE. 0.1) THEN 
BUF (  3)— 999.0 
BUF (  4  )  —  999 . 0 
END  IF 

I F ( BUF { 5 ) . LE.0.1 )THEN 
BUF{  6  )— 999.0 
BUF ( 7  ) *-999 . 0 
END  IF 

Z  IN( I PO SLOOP , K )  -  BUF ( 1 ) 

TEMP_IN ( I POSLOOP , K )  -  BUF{3) 

SAL_IN(  I POSLOOP, K)  -  BUF(6) 

IF  (  K.GT.l  .AND.  TEMP_IN ( I POSLOOP , K )  .LE. -998.0)  THEN 
TEMP_IN( IPOSLOOP,K)  -  TEMP_IN( IPOSLOOP, K-l ) 

END  IF 


onnnnn  nnnnnonnnnono  non 


IF  (  K  GT.l  .AND.  SAL_IN ( I POSLOOP , K )  .fR.  -998.0)  THEN 
SAL_IN( IPOSLOOP , K )  -  SAL_IN( IPOSLOOP , K-l ) 

END  IF 

WRITE( 11, 140)  IPOSLOOP, K, TEMP  IN ( I POSLOOP , K ), SAL  IN ( I POSLOOP , K ) 


50  CONTINUE 
200  CONTINUE 


CLOSE ( UNIT* 10 ) 


★  CLOSE  THE  LEVITUS  FILE  * 


★ 

INTERPOLATE  TEMPERATURE  AND  SALINITY  PROFILES  FROM  THE  INPUT  * 
PROFILES  ONTO  THE  SECTION  * 

* 

1.  First,  compute  the  distance  between  the  profiles  and  use  as  * 

input  distance.  * 

2.  Second,  fill  T,S  to  desired  depth  if  required  * 

3.  Interpolate  to  the  z-grid  * 

4.  Interpolate  to  the  x-grid  * 

5.  Compute  Brunt-Vai sala  frequencies  * 

★ 


D_PROFILES  *  DI ST ( LATl , LONl , LAT , LON ) 
X_BASE ( 1 )  -  0.0 
X  BASE ( 2 )  -  D  PROFILES 


210 


DO  210  I  -  1 , NX 

X_OUT ( I )  -  ( 1-1 ) *DX 
CONTINUE 


DO  220  I  -  1 , NZ 

Z_OUT ( I )  »  ( 1-1 ) *DZ 
ZBV(I)  -  Z_OUT ( I ) 
220  CONTINUE 


X  RATIO  -  XMAX/D  PROFILES 


I F (  GM  PROF)  THEN 


DO  230  K  -  1 , NX 

BVMAX(K)  -  2.99 
DO  240  I  -  1 , NZ 

BVF ( I , K )  -  3 . 0 *EXP ( -ZBV (I) /1 300.0) 

I F (  I.LT.4)  BVF ( I , K )  -  2.99 
240  CONTINUE 

230  CONTINUE 


FMAX  -  2.99 
RETURN 


ELSE 

*  Set  up  starting  * 

*  temperature  * 

*  and  salinity  * 

*  profiles  * 


non  nonoo  nonnooo 


DO  250  I  -  1,30 

T_TEMP ( I )  -TEMP_IN ( 1,1) 

S_TEMP ( I )  -  SAL_IN ( 1,1) 

250  CONTINUE 

CALL  INTRPL ( 6 , 30 , ZLEV, T_TEMP , NZ , Z_OUT, DUMMY ) 

DO  260  I  -  1 , NZ 

TEMP (1,1)  -  DUMMY ( I ) 

260  CONTINUE 

CALL  INTRPL (6,30 , ZLEV , S_TEMP , NZ , Z_OUT , DUMMY ) 

DO  270  I  -  1 , NZ 

SAL (1,1)  -  DUMMY ( I ) 

270  CONTINUE 

*********************** 

*  Set  up  ending  T,S  * 

*  profiles,  scaled  * 

*  by  ratio  of  xmax  to  * 

*  distance  between  * 

*  input  profiles  * 

*********************** 

DO  280  1-1,30 

T_TEMP ( I )  -  TEMP_IN ( 2,1) 

S_TEMP ( I )  -  SAL_IN ( 2,1) 

280  CONTINUE 

CALL  INTRPL (6,30, ZLEV , T_TEMP , NZ , Z_OUT , DUMMY ) 

DO  290  I  -  1 , NZ 

TEMP ( I , NX )  -  ( DUMMY ( I ) —TEMP (1,1)) *X_RATI O  +  TEMP ( I , 1 ) 
290  CONTINUE 

CALL  INTRPL (6,30, ZLEV , S_TEMP , NZ , Z_OUT , DUMMY ) 

DO  300  I  -  1 , NZ 

SAL ( I , NX )  -  ( DUMMY ( I ) -SAL (1,1)) *X_RATIO  +  SAL ( I , 1 ) 

300  CONTINUE 

★**★*★★*****★*★*★★**★** 

*  Fill  the  temp,  sal  * 

*  arrays.  Use  linear  * 

*  interpolation.  * 

*********************** 

DO  310  I  -  1,NZ 

CALL  LINT( TEMP( I , 1 ) , TEMP ( I , NX ) , NX, DUMMY) 

DO  320  K  -  2,  NX-1 
TEMP ( I , K )  -  DUMMY ( K ) 

320  CONTINUE 

CALL  LINT (SAL (1,1) , SAL (I, NX) , NX, DUMMY) 

DO  330  K  -  2,  NX-1 
SAL ( I , K )  -  DUMMY ( K ) 

330  CONTINUE 

310  CONTINUE 

************************ 

*  Compute  BV  Freqs  * 

************************ 


C  *  Set  min  of  max  bvf's  * 

FMAX  -  1.0E10 
DO  340  K  -  1 , NX 
BVMAX ( K )  -  0.0 

DO  350  1=1 , NZ-1 


T_TEMP ( 1 )  -  TEMP ( I , K ) 

T_TEMP ( 2 )  -  TEMP ( 1+1 , K ) 

S_TEMP ( 1 )  -  SAL ( I , K ) 

S  TEMP ( 2 )  -  SAL ( 1+1 , K ) 

Pll)  -  Z_OUT(I) 

P ( 2 )  -  Z_OUT ( 1+1 ) 

BVF (  I  ,  K  )  -  BVFRQ ( S_TEMP , T_TEMP ,  P  ,  2  , PAV , E ) 

I F ( BVMAX ( K ) . LT . BVF ( I , K ) ) BVMAX ( K )  -  BVF(I,K) 
350  CONTINUE 

BVF ( NZ , K )  *  BVF ( NZ-1 , K ) 

I F ( FMAX  .GT.  BVMAX { K )) FMAX  -  BVMAX ( K ) 

340  CONTINUE 

END  IF 
999  RETURN 


9091 

9092 


STOP  'ERROR  IN  OPENING  LEVITUS  FILE 
STOP  'ERROR  IN  READING  LEVITUS  FILE 


100 

1 

FORMAT ( 

'  PROFILE  ',14,'  X  -  ' , F10 . 3// 

'  Z  T  S 

BV  '//) 

110 

FORMAT ( 

4F12.3) 

120 

FORMAT ( 

***********  INITIAL  INTERPOLATE  PROFILES  TEMP, SAL, BVF ' , 

1 

'  ARRAYS  ****★***★****'//) 

130 

FORMAT ( //'  INPUT  TEMPERATURE  AND  SALINITY  PROFILES 

'//) 

140 

FORMAT ( 

IX, 214 , 2F12 . 3  ) 

END 


ononoonnnnnnoonnnooonnnonnnnoooonnn 


SUBROUTINE  INT  WAVE  SIMULATION 


*  *■ 

*  !. 


PROGRAM 

PURPOSE 

HISTORY 
AUTHOR ( S ) 


* 

I NT_WAVE_S I MULATI ON  * 

* 

Does  most  of  the  calculations  for  MODELl.  It  is  based  * 
on  the  Garrett-Munk  internal  wave  model.  * 

* 

10/26/88  Coding  begun  * 

* 

K.D.  Saunders  (NOARL)  * 

* 

* 


INPUT  All  interprocess  communication  is  via  named  common. 

* 

* 


OUTPUT  All  output  is  done  in  subroutine  calls. 


* 

Notes  * 

Subroutines  called:  * 

MODE_CALC  * 

DISPLACEMENTS  * 

PROFILE_CALC  * 

* 


IMPLICIT  NONE 
INCLUDE  'MODEL!. INC' 


LOG I CAL *1 

LOGICAL 

INTEGER 

INTEGER 

REAL 


BV_CHANGED  /  .TRUE.  / 
RESTART 

IDIR , NBV, NNZ , I IX, IT_T, ITO 
NDIR 

Z  T ( MAX ) , BVT ( MAX ) 


COMMON  /EIGJCOM/RESTART 
COMMON  /DIR/  NDIR, ITO 


NMODES  -  5 

NF  -  8 

NBV  -  NZ 

NNZ  -  NZ 

READ( 16 , REC*3  )  NT , DT , TMAX 
READ( 16,REC-5)  TO,  ITO  , NDIR 
READ ( 16 , REC“6 )  NEIG, NMODES, NF 


<">  n  o  non  ononoonno 


WRITE (13, 120)  NT, NX, NZ,DT,DX,DZ, TO, LAT, LON, AZIMUTH 
TMAX  -  NT*DT 


WRITE ( 16 , REC“3 )  NT, DT, TMAX 

WRITE ( * , * )  '  NT, DT, TMAX, ITO  ',  NT , DT , TMAX , ITO 
IF  (ITO  .GT.  NT)  ITO  -  NT 
DO  360  IT  -  ITO  +  1  ,  NT 
T  -  (  IT  -  1  )  *  DT 


DO  370  IX  -  1 , NX 

DO  380  K  -  1 , NBV 

BVT(K)  -  BVF ( K , IX ) 

ZT(K)  -  ZBV(K) 

380  CONTINUE 

IDIR  -  0 

************************ 

*  This  is  the  same  call* 

*  as  in  Rubenstein ' s ,  * 

*  except  for  the  IX  * 

*  parameter.  The  * 

*  displacements  are  * 

*  computed  at  each  * 

*  range.  * 

************************ 

CALL  DISPLACE ( ZD, NNZ , NX, 1000. *XMAX,T, 

1  AZIMUTH, IDIR, NF,NMODES, 

2  LAT , NBV , ZT , BVT , IX , 

3  MAX , MAX , FMAX , IT , NEIG , 

4  TIDES) 

CALL  PROFILE_CALC 

*************** 

*  END  IX-LOOP  * 
*************** 

370  CONTINUE 


RESTART  -  .TRUE. 

WRITE ( 16 , REC“5 )  T, IT,NDIR 

*************** 

*  END  IT-LOOP  * 
*************** 

360  CONTINUE 


RETURN 


100  FORMAT ( 

1 
2 


IX , NX , NZ , NBV, NF , NMODES  -',7110/ 
XMAX  -  ' ,G15 . 4 , '  T  -  ' ,G15 . 4 , 
LAT  -  ' ,G15.4//) 


120  FORMAT(  '  ********  OCEAN  SIMULATION  MODEL  VERSION  1.0  '// 


1 

'  NT 

'  ,15/ 

2 

'  NX 

'  ,15/ 

3 

'  NZ 

',15/ 

4 

'  DT 

' , G20 . 5/ 

5 

'  DX 

' , G20 . 5/ 

6 

'  DZ 

' , G ’ n . 5/ 

>  l£>  CD  -J 


'  TO  ' ,G20 . 5/ 

'  LAT  ' , G20 . 5/ 

'  LON  ' ,G20 . 5/ 

'  AZ  ' , G20 . 5//) 

END 


onnoonoooonoonooonoononooonoonnnnnnnnonnoooooonono 


************** 

************** 

INFORMATIONAL 

************** 

************** 

PROGRAM 

PURPOSE 

AUTHOR 

HISTORY 


INPUT 


NOTES  : 


DOCUMENTATION  ONLY  !  * 

DPERT  * 

* 

* 
* 
* 
* 
* 
* 
* 
* 


COMPUTES  RANDOM  INTERNAL  WAVE  DISPLACEMENTS 

D .  RUBENSTEIN  (SAIC)  -  ORIGINAL  AUTHOR  (LOWER  CASE) 
K.D.  SAUNDERS  ( NOARL ) -  MODIFIER  (IN  CAPS) 


9/25/88 

9/26/88 


10/24/88 

FILE  NAME 
DATA  IN  « 
Line  1 

nf 


RECEIVED  AT  NOARL 

INITIAL  MODIFICATION  TO  RUN  ON  UVAX 

a.  Changed  rands,  rnd  to  RAN 

b.  Set  up  output  file 
data . 

Added  documentation 


«  filename 
filename  » 


» (CHARACTER) 


Line 


Line 


nmodes 
nbv 
nz 
lat 
2 

nx 

totx 

nt 

dt 

angle 

idir 

0 

1 

2 

3  -  2+nbv 
z  (  j  ) 
bv  ( j  ) 


number 
numbe  r 
number 
number 


of 

of 

of 

of 


-  latitude 


frequencies 
modes 
points 
points 


in  expansion 


in  bv  profile 
in  vertical 


number  of  points  in  horizontal 
total  distance  in  x-direction  (m) 
number  of  time  steps 
delta  time  (sec) 

Azimuth  angle  of  vertical  plane 
directionality  flag 

-  isotropic 

*  Along-range  propagation 

-  Cross-range  propagation 

depth  (m) 

BV  frequency  (cph) 


for  displacement* 

* 

* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 


(°) 


ky-0 

kx-0 


1.  This  program  computes  internal  wave  displacements  in  * 
the  x-z  plane  at  equally  spaced  times.  The  program  * 

reads  a  data  file  containing  the  control  parameters  * 

and  a  single  Brunt-Vai sala  frequency  profile.  All  the  * 
displacements  are  computed  for  this  single  profile.  * 

* 

* 

>********************************^************************ 


o  o  o  n  o 


SUBROUTINE  DISPLACE 

1 

2 


Z,  NZ,  NX,  TOTX ,  T,  ANGLE,  IDIR, 
NF,  NMODES,  LAT,  NBV,  ZT,  BVT  ,IX, 
NBVMAX , NXMAX , FMAX, IT, NEIG, TIDES) 


PROGRAM 


DISPLACE 


PURPOSE: 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c* 


Calculate  random  vertical  displacements  (correlated  in  time)  due  to 
internal  waves.  A  Garrett-Munk  type  of  spectrum  is  used  to  generate 
proper  energy  levels.  The  displacements  are  packed  into  array  Z(NZ,) 
which  covers  a  vertical  plane. 

Input  Parameters 


NZ 

NX 

TOTX 

T 

ANGLE 

IDIR 


NF 

NMODES 

LAT 

NBV 

ZT 

BVT 


Number  of  points  in  the  vertical  used  in 
calculating  modes  (IntegerM) 

Number  of  points  in  the  horizontal  (IntegerM) 

Total  distance  in  x-direction,  in  meters  (RealM) 

Time  in  seconds  (Real*4) 

Azimuth  angle  of  the  vertical  plane,  in  degrees 
Flag  for  directionality  of  internal  waves 
■  0  Isotropic 

-  1  Along-range  propagation  (ky  ■  0) 

*  2  Cross-range  propagation  ( kx  -  0) 

Number  of  frequencies  in  expansion  (IntegerM) 

Number  of  modes  in  expansion  (IntegerM) 

Latitude,  in  degrees  (RealM) 

Number  of  points  in  BV  profile,  and  in  output  array  Z(lntege 
Depths  of  BV  frequencies,  and  of  output  displacements  Z, 
in  meters  (RealM  array  of  length  NBV) 

Set  of  BV  frequencies,  in  cph  (RealM  array  of  length  NBV) 


Output  parameter 


Array  of  vertical  displacements, 
of  size  NBVMAX  x  NXMAX 


in  meters  (RealM  2-D  array 


Note:  The  BV-frequency  array  BVT  is  of  length  NBV,  which  is  interpola 
onto  a  regularly  spaced  grid  of  length  NZ.  The  output  array  WM  from 
subroutine  MODESUB  is  interpolated  back  into  a  grid  of  length  NBV. 

MAX  is  the  maximum  number  of  depth  points  allowed  in  MODESUB  calculat 
********************************************************************** 


r  *  *  *  *  * 
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* 
* 
* 
* 
* 

the  * 

* 

9 

* 

* 

* 

* 

* 

* 

* 

* 

* 

it 

it 

it 

* 

* 

* 

it 

it 
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* 
* 
* 
* 
* 
★ 
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★ 
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ted  * 

it 

it 

* 
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* 

***** 


PARAMETER  (  MAX  -  8000,  MODEMAX  -  50,  NFMAX  -  bO  ,  NDIRMAX-50) 


REAL  Z(NBVMAX),  BVT ( NBVMAX ) ,  ZT(NBVMAX),  LAT 
REAL  F ( NFMAX ) ,  FR(NFMAX),  ZDEP(MAX),  WMINT ( MAX ) 

REAL  K ( 0 : MODEMAX ) ,  WM( MAX , 0 : MODEMAX ), KSTART ( 0 : MODEMAX , NFMAX ) 

REAL  KX,  KY  ,  FMAX 

REAL  COST( 0 : MODEMAX, NFMAX, NDIRMAX) ,  SINT( 0 : MODEMAX, NFMAX , NDIRMAX ) 

REAL  PHASE( 0 : MODEMAX , NFMAX , NDIRMAX) , 

1  U(1000) ,V(1000) ,W(1000) ,FF,DZ,UF,VF, UMAG, VMAG , WMAG, ZMAG, 

2  DCZMAG,DFF( NFMAX) , YFK ( NFMAX ) , YFL ( NFMAX ) , 

3  EPSILON, QQU,QQV,QQF,QQZ,QW,QDW 

COMPLEX  A( 0 : MODEMAX, NFMAX ) ,  11,  FACTOR,  DCZ 
1  , VTT , UTT , ZTT , WTT , QF1 , QFU , QFV , QFZ 


INTEGER 

ISEEDO  /191531459/ 

1 

I  SEED , 

2 

IX, 

3 

IT, 

4 

NX, 

5 

LOC  REC, 

6 

LOC  REC1 , 

7 

NDIR, 

8 

IID 

LOG I  CAL* 1  FIRSTPASS 

1  FIRSTGO 

2  TIDES 
LOGICAL  RESTART 


/.TRUE./, 

/.TRUE./, 


COMMON  /DIR/  NDIR 

COMMON  /EIG_COM/  RESTART 

DATA  JSTAR  /  3  / 


noon  non  non  noooo 


c  * 

c  FI  and  BVMAX  are  inertial  frequency  and  maximum  BV  frequency,  in  cph.* 
c  * 

C  * 

C  INITIALIZE  VARIABLES  ON  EACH  PASS  THROUGH  THIS  ROUTINE  * 

DZ  -  ZT( 2 )-ZT( 1 ) 

I  SEED  -  ISEEDO 

II  -  (0. ,  1. ) 

PI  -  4 . *ATAN( 1 . ) 

DEGRAD  -  PI/180. 

*  Added  11/8/88  -  kds  to  * 

*  to  conform  to  Garrett-Munk  * 

*  form  -  p57  in  Flatte  * 

JSTAR  -  3 

FACTOR  -  (0,0) 

KX  *  0 

KY  -  0 


I F (  FIRSTPASS  )  THEN 

FIRSTPASS  -  .FALSE. 

*  COMPUTE  THE  INTEGRAL  OF  N(z)* 

★  ★★★★★★★★★★★★★★★A************** 

W  -  0 

DO  390  I  -  2 , NBV— 1 
W  -  W  +  BVT ( I ) 

390  CONTINUE 

W  -  W  +  0 . 5* ( BVT ( 1 ) +BVT ( NBV ) ) 

W  -  DZ*W*2*  PI/3600 . 0 

SQNDIR  -  NDIR 
SQNDIR  -  sqr t ( SQNDIR ) 

WRITE( 11 ,7020 )  NDIR, SQNDIR 

DO  400  M  -  0 , MODEMAX 
K(M)  -  0 

400  CONTINUE 


*  Get  array  of  frequencies,  in  cph  * 


FI  -  SIN(DEGRAD*LAT)/12.0 
FIR  -  2 . *PI*FI/3600 . 

DX  -  TOTX  /  (NX-1.0) 


*  COMPUTE  CENTER  FREQUENCIES  * 

*  AND  DF'S  * 

*★★**★★**★****★★*  ************* 


DY 

-  LOG10 ( 

F MAX/FI )/NF 

DO 

410  I  - 

1 , NF+1 

YFK(I)  - 

( 1-0 . 5 ) *DY 

YFL(I)  - 

( 1-1 ) *DY 

non  nn  non  nnnno  nooono  noonnn 


410 


CONTINUE 


*  Fixed  frequencies  * 

*  used  to  facilitate  * 

*  eigenvalue  comp's  * 

DO  420  I  -  1,  NF 

F ( I )  -  FI  +  ( 1-0 . 5 ) *DF 
F ( I  )  -  FI*10 . 0** ( YFK( I ) ) 

DFF(I)  -  FI  * ( 1 0 . 0  *  *  YFL ( 1  +  1 )  -  10.0**YFL(I)  ) 

FR( I )  -  F( I ) *2 . *PI/3600 . 0 
420  CONTINUE 

★  ★★★★*★★*★★★*★****★★★★★★****★★***★*★★*★**★**★*★★★***★***★★***★**★★★★*★*★ 

Note:  Ordinarily,  both  F  and  DF  should  both  be  in  units  of  rad/sec.  * 

Since  DF  is  being  divided  by  F,  and  they  are  both  in  the  same  units  * 
of  cph,  their  units  do  not  need  to  be  converted  (except  in  the  * 

exponential ) .  * 

★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★A 

COSANG  -  COS  (  ANGLE  *  DEGRAD  ) 

SINANG  -  SIN  (  ANGLE  *  DEGRAD  ) 

ISEED  -  ISEEDO 
PHI  -  RAN( ISEED) 

DO  430  I ID  -  1 , NDIR 

DO  140  IFREQ  -  1 ,  NF 

DO  141  M  «  0,  NMODES 

ADJUST  TO  CONVENTIONAL  DEFINITION  OF  MODE  NUMBER  FOR  THE  GARRETT-MUNK  * 
SPECTRAL  POWER  ROUTINE.  (THE  LOWEST  MODE,  WITH  NO  ZERO-CROSSINGS ,  * 

IS  M-0,  OR  J-l)  * 

****★***★*****★*★*★*★*★*****★**★**★★★*★**★*★*★***★****★*★**★*★**★★**★***★ 

J  -  M  +  1 

JMODES  -  NMODES  +  1 

********************************* 

*  DIRECTIONALITY  OF  PROPAGATION  * 
********************************* 

IF  (  IDIR  .EQ.  0  )  THEN 

THETA  -  2 . *pi*RAN( ISEED) 

WRITE ( 6 ,7100 )  M, IFREQ, I ID, ISEED, THETA 
WRITE (11,7100)  M, IFREQ, I ID, I  SEED, THETA 
COST(M, IFREQ, iid)  -  COS ( THETA ) 

SINT(M, IFREQ, iid)  -  SIN ( THETA) 

ELSE 

COST(M, IFREQ, iid)  -  0. 

SINT(M, IFREQ, iid)  -  0. 

IF  (  IDIR  .EQ.  1  )  COST(M, IFREQ, iid)  -  1.0 
IF  (  IDIR  .EQ.  2  )  SINT(M, IFREQ, iid)  -  1.0 
END  IF 

THETA  -  2 . *PI *RAN ( ISEED) 

PHASE(M, IFREQ, IID)  -  THETA 

IF( IID  .EQ.  1)  THEN 

PHI  -  2 . *PI*RAN( ISEED) 

******************************* 

*  NO  -  3  CPH  -  0.005236  RAD/S  * 
******************************* 

VN  -  0.005236 

SPEC  -  2  .  *VN*W*SZ(FR(  IFREQ)  ,  J, 


nonnnn  non  nnnn  non  non  non  non  non 


1 


JSTAR, JMODES , FIR) 

A( M ,  I FREQ )  -  SQRT( SPEC )  *  CEXP(Il*PHI) 

END  IF 

********************* 

*  END  MODES  LOOP,  M  * 

141  CONTINUE 

****************** 

*  END  I FREQ-LOOP  * 
****************** 

140  CONTINUE 

*************************** 

*  END  DIRECTION  LOOP,  IDD  * 
*************************** 

430  CONTINUE 

****************** 

*  END  FIRST-PASS  * 
****************** 

END  IF 


***************** 

*  Initialize  Z  * 
***************** 

J  -  IX 

DO  160  I  -  1,  NBVMAX 

Z ( I )  *  0.0 

U( I )  -  0.0 

V( I )  -  0.0 

W( I )  =0.0 

160  CONTINUE 

IPRINT  =  0 
EPSILON  =  0.001 

************************* 

*  MOVED  OUTSIDE  IZ  LOOP  * 

*  10/27/88-KDS  * 

************************* 

RANGE  =  ( IX-1 . ) *DX 
X  =  COSANG  *  RANGE 
Y  =  SI NANG  *  RANGE 

WRITE ( * , * )  '  IX, RANGE ', IX, RANGE 

***************************** 

*  TEST  FOR  VARIABLE  BV  FREQ  * 
***************************** 


I F (  NEIG  .GT.  1)  THEN 

LOC_REC  =  NF*(NMODES+l)*( IX-1) 

ELSE 

LOC_REC  -  0 
END  IF 

DO  300  I  FREQ  »  NF,  1,  -1 

FACTOR=CEXP ( -I 1 *F ( I  FREQ )*T*2.*PI/3600.  ) 

************************************ 

*  sqrt ( df/ndi r )  added  2/2/89  to  * 

*  take  care  of  convergence  in  the  * 

*  stochastic  integral  sense.  (See  * 

*  Kinsman,  1965,  p368  ff  for  * 

*  details.  * 


n  n  n  n 


*****  * ****************************** 

DO  440  M  -  0 , NMODES 
I F ( FIRSTGO )  THEN 

K(M)  -  0.0 

ELSE 

K(M)  -  KSTART( M , I  FREQ ) 

END  IF 
CONTINUE 

I F (  .NOT.  RESTART  )  THEN 
WRITE ( * ,*) 

'  CALLING  MODESUB  :  RESTART , I  FREQ  -  RESTART, IFREQ 

CALL  MODESUB  (  NMODES,  F( IFREQ),  NBV ,  ZT,  BVT ,  NZ ,  LAT, 
EPSILON, 

IPRINT  ,  K,  ZDEP,  WM  , FIRSTGO) 


I F (  IPRINT  .GE.  1)  THEN 

WRITE ( 1 1 , * ) ' I  FREQ* '  , I  FREQ , F ( I  FREQ ) ,  '  K  -  ' 

WRITE (11,*) ( K ( M ) ,M*0, NMODES) 

END  IF 

END  IF 

IF(IX.EQ.l)  THEN 

WRITE (  20,6002)  IFREQ, F( IFREQ) , FR ( I  FREQ ) 

END  IF 

//  '  If req  -  '  ,  i5/ 

'  Freq  -  '  ,  g20 . 5/ 

'  Rad.  Freq',  g20.5//) 


DO  250  M  -  0,  NMODES 

I F ( IX  . EQ . 1 )  WRITE( 20,6001)  M , K ( M ) 

6001  FORMAT (  '  Mode  «  ',  15/ 

1  '  k ( ra )  -  ',  g20 . 8//) 

I F (  .NOT.  RESTART  )  THEN 
KSTART(M, IFREQ)  -  K ( M ) 

******************** 

*  UPDATE  INITIAL  K  * 

*  MATRIX  * 

******************** 

IF  (  K ( M )  .LE.  l.E-18  )  THEN 
WRITE(11,170)M, IFREQ 
WRITE(6,170)M, IFREQ 

FORMAT ( '  Mode  ',i3,'  of  Frequency  #',i3, 

'  did  not  converge.',/,'  Increase  NZ .  Program  aborting') 
STOP  '  ERROR  -  NO  MODAL  CONVERGENCE' 

ENDIF 

END  IF 

C  ********************************************************* 

C  INTERPOLATE  WM,  OF  LENGTH  NZ  INTO  WMINT ,  OF  LENGTH  NBV  * 

Q  ********************************************************* 

LOC  REC  -  LOC  REC  +  1 


170 

1 


6002 

1 

2 

3 


440 

1 

1 

2 


non 


I F (  .NOT.  RESTART)  THEN 

CALL  INTERP  (  NZ , ZDEP , WM ( 1 , M ) , NBV , ZT ( NBV ) , ZT , WMINT ) 

INQUIRE ( UNIT-15 , RECL-NREC1 5 ) 

WRITE (15, rec— LOC_REC )  K(M) , (WMINT(KK) ,KK-1,NBV) 

ELSE 

INQUIRE ( UNIT-1 5 , RECL-NREC1 5 ) 

READ  (15, rec-LOC_REC )  K ( M ),( WMINT ( KK ), KK-1 , NBV ) 

END  IF 

7990  FORMAT (  IX , G2 0 . 8 , ( IX , 1 5 , G2 0 . 5 ) ) 

DO  450  I ID  -  1 , NDI R 

KX  -  COST ( M , I  FREQ , I ID )  *  K ( M ) 

KY  -  SINT(M, IFREQ, I I D )  *  K(M) 

I F ( KX  .EQ.  0)  KX  -  1.0E-9 
I F ( KY  .EQ.  0)  KY  -  1.0E-9 
IF(IX.EQ.l)  THEN 

WRITE ( 20,6003)  KX, KY, abs( a(m, if req) ) 

END  IF 

6003  FORMAT (  '  KX  -  ',G20.5/'  KY  -  ',G20.5/ 

1  'A(m,ifreq)  -  ',g20.5//) 

IF ( IPRINT  .EQ.  -1)  THEN 

WRITE ( 11 , 4000 )  M, IFREQ, IID,K(M) ,KX,KY, 

1  A(M, IFREQ) , FACTOR 

4000  FORMAT (1X,3I4,7G15.4) 

END  IF 

XXKK  -  KX* KX  +  KY*KY 

FF  -  FR( IFREQ) 

DFR  -  2*PI*DFF( I  FREQ ) /36  00 . 

BFACT  -  sqrt ( df r/ndi r ) 

QFl  =  BFACT*  A(M, IFREQ)  *  FACTOR  * 

1  CEXP ( 1 1  * ( KX*X  +  KY* Y 

2  +  PHASE (M, IFREQ, I ID)  )  ) 

QFU  -  (-11)  *  ( I1*FIR*KY+FF*KX)  /  ( FF*XXKK ) 

QFV  -  (-11)  *  ( I1*FIR*KX+FF*KY)  /  ( FF*XXKK ) 

QFZ  -  1 . 0/( I 1 *FF ) 

QQU  -  REAL { QFl *QFU ) /DZ 
QQV  -  REAL ( QFl *QFV ) /DZ 
QQF  =  REAL ( QFl ) 

QQZ  -  REAL ( QFl *QFZ ) 

DO  220  IZ  -  1,  NBV 
QW  -  WMINT ( I Z ) 

I F ( I Z  .GT.  1  .AND.  K ( M )  .GT.  1.0E-5)  THEN 
QDW-  WMINT( IZ-1 )-QW 
U(IZ-l)  -  U(IZ-l)  +  QQU*QDW 
V(IZ-l)  -  V(IZ-l)  +  QQV* QDW 
END  IF 

W( IZ )  -  W( IZ )  +  QQF*QW 
Z(IZ)  -  Z(IZ)  +  QQZ *QW 
220  CONTINUE 

*************************** 

*  END  DIRECTION  LOOP ,  I ID  * 
*************************** 

450  CONTINUE 

+★*********★★**★★★*** 


o  n  o  on 


250  CONTINUE 


300  CONTINUE 


*  END  MODE  LOOP,  M  * 

*  END  FREQUENCY  LOOP, 


★  I 

I  FREQ  * 

*  ★  ★  ★  ★  ★  i 


c*********************************************************************** 

c 

C  M2  TIDAL  COMPONENT  GOES  HERE 

C 

£*********************************************************************** 

I F (  TIDES)  THEN 

DO  460  M  -  0 , NMODES 
K(M)  -  0.0 
460  CONTINUE 

C 
C 
C 

FM  -  1.0/12.4 
FMR  -  2*PI *FM/3600 . 0 
FIRSTGO  -  .TRUE. 

IF  (  .NOT.  RESTART  )  THEN 

CALL  MODESUB  (  NMODES,  FM,  NBV ,  ZT,  BVT ,  NZ ,  LAT, 

1  EPSILON, 

2  IPRINT  ,  K,  ZDEP,  WM  , FIRSTGO) 

DO  470  M  =0, NMODES 

WRITE( 6,8010)  M , K ( M ) 

8010  FORMAT( IX, 15, 5X,G20 . 8 ) 

470  CONTINUE 

END  IF 


*  M2  TIDAL  FREQUENCY  * 


DO  240  M  -  0, NMODES 


C 

C 

C 

C 


I F (  .NOT.  RESTART  )  THEN 
KSTART ( M , I  FREQ )  -  K ( M ) 

a******************* 

*  UPDATE  INITIAL  K  * 

*  MATRIX  * 

******************** 

IF  (  K ( M )  .LE.  l.E-18  )  THEN 
WRITE ( 11 , 170 )M, I  FREQ 
WRITE ( 6 , 170 )M, IFREQ 

STOP  '  ERROR  -  NO  MODAL  CONVERGENCE ' 

END  IF 
END  IF 


C  * 
C  Interpolate  WM,  of  length  NZ  into  WMINT ,  of  length  NBV  * 
C  * 

LOC  REC  -  LOC  REC  +  1 


IF (  .NOT.  RESTART)  THEN 

CALL  INTERP  (  NZ , ZDEP , WM ( 1 , M ), NBV, ZT ( NBV ), ZT , WMINT ) 


C 

C 

c 

c 


c 

c 

c 


*************************** 

*  NORMALIZE  INTERNAL  M2  * 

*  TIDAL  EIGENFUNCTIONS  * 

*************************** 

ANORM  -  1.0 
AMPLITUDE  -  1 . 0/( M+l ) 

*********************** 

*  Assume  M2  tide  has  * 

*  n  base  amplitude  of  * 


n  n  o  non  nnonnoo  *»nono 


*  i.  meters  scaled  by  * 

*  the  mode  no.  * 

*********************** 

ANORM  -  AMPLITUDE* ANORM 
WMAX  -  0 

*  Apply  normalization  * 

DO  480  IZ  -  1 , NBV 

WMINT(IZ)  -  ANORM*WMINT( IZ ) 

80  CONTINUE 

INQUIRE (UNIT-1 5 ,RECL-NREC1 5 ) 

WRITE ( 1 5 , REC-LOC_REC )  K  (  M )  , (WMINT(KK) ,KK-1 ,NBV) 

ELSE 

INQUIRE (UNIT-1  5, RECL-NREC1 5) 

READ  ( 15,REC-LOC_REC)  K ( M ) , ( WMINT ( KK ) , KK-1 , NBV ) 

END  IF 

************************************************************************ 


NORMALIZE  INTERNAL  TIDE  EIGEN  FUNCTIONS  * 

* 

************************************************************************ 

*  For  now,  set  ky  * 

*  to  zero  * 

KX  -  K  (  M  ) 

KY  -  0.0 

XXKK  -  K(M)*K(M) 

FACTOR_M2  -  CEXP ( -1 1  * FM*T*2 . *PI/3600 . ) 

FF  -  FM 

QFl  -  FACTOR  M2  *  CEXP(  Il*(KX*X  +  KY*Y )  ) 

QFU  -  (-11)  *  Tll*FIR*KY+FF*KX)  /  ( FF*XXKK ) 

QFV  -  (-11)  *  ( Il*FIR*KX+FF*KY)  /  ( FF*XXKK ) 

QFZ  -  1.0/(I1*FF) 

QQU  -  REAL ( QFl *QFU)/DZ 
QQV  -  REAL( QFl*QFV)/DZ 
QQF  -  REAL ( QFl ) 

QQZ  -  REAL ( QFl *QFZ ) 


DO  230  IZ  -  1,  NBV 

QW  -  WMINT ( I Z ) 

I F ( I Z  .GT.  1  .AND.  K ( M )  .GT.  1.0E-5)  THEN 
QDW-  WMINT( IZ-1)-QW 
U(IZ-l)  -  U(IZ-l)  +  QQU*QDW 
V(IZ-l)  -  V(IZ-l)  +  QQV* QDW 

END  IF 

W( IZ )  -  W( IZ )  +  QQF*QW 
Z(iz)  -  Z(iz)  +  QQZ *QW 
230  CONTINUE 

******************* 

*  END  MNODES-LOOP  * 
******************* 

240  CONTINUE 

************* 

*  FOR  TIDES  * 
************* 

END  IF 

LOC  REC1  -  NX* (IT-1)  +  IX 

WRITE (14, REC-LOC_RECl )  (U(IZ),V(IZ),W(IZ) ,IZ-1,NBV) 

I F (  NEIG.EQ.l)  RESTART  -  .TRUE. 


FIRSTGO 


.FALSE. 


RETURN 

7000  FORMAT (//5X, ' M '  , 4X , ' IF ' , 3X , ' I ID '  , 1 5X , ' I  SEED'  ,  11X, 'THETA'//) 

7020  FORMAT (  //  '  NDIR  -  ',15// 

1  '  SQNDIR  -  ' , F12 . 4//) 

7100  FORMAT {2X,3l5,5X,l20,G16.5) 

END 


nnnno  non  nonnooonnnn 


FUNCTION  SZ  (  F,  J,  JSTAR ,  JMODES,  FIR  ) 

C* **********************************************  -A*************************** 

* 

* 

COMPUTE  SPECTRAL  DENSITY  OF  VERTICAL  DISPLACEMENT  * 

* 

INPUT  PARAMETERS:  * 

* 

F  Frequency,  in  rad/sec  * 

J  Vertical  mode  number  * 

FIR  Inertial  frequency,  in  rad/sec  * 

* 

★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★Ik 


DATA  B/1300 ./ 

PI  ■  4 . *ATAN ( 1 . ) 

E  -  6.3  E-5 

BW  -  ( 2 . 0*FIR)/( PI*F*SQRT( F**2  -  FIR**2)) 


GET  H ( J )  * 


SUM  -  0. 


Removed  11/8/88  -  kds  * 

do  20  jj  ■  1,  jmodes,  2  * 


JMAX  -  JMODES 
JMAX  -  100 

DO  20  JJ  -  1,  JMAX 

SUM  -  SUM  +  l./(JJ*JJ  +  JSTAR* JSTAR ) 
20  CONTINUE 

HJ  -  (l./(J*J  +  JSTAR* JSTAR ) )  /  SUM 

SZ  -  ( B* *2 )  *  BW  *  HJ  *  E 

RETURN 

END 


nonnnonnonnnnonnnnnnoooooonnnnnonnnonoooooonnnnoooonnnonnnnoon 


SUBROUTINE  MODESUB  (  NMODES ,  F,  NBV,  ZT,  BVT ,  NZ  ,  LAT,  EPSLON, 

1  IPRINT,  K,  Z,  WM  , FIRSTGO ) 

* 

This  routine  computes  the  internal  wave  vertical  modes  and  horizontal  * 
wavenumbers  for  a  prescribed  Vaisala  frequency  profile,  at  a  given  set  * 
of  frequencies.  The  ODE  which  is  solved  is  * 

★ 

( N ( z ) * *2  -  F**2  )  * 

w"  +  [  k  *  *  2  ]  * - w  -  0  ,  * 

(  F**2  -  Fi **2  )  * 

* 

where  w  is  vertical  velocity,  N(z)  is  Brunt-Vaisala  frequency,  k  is  * 

wavenumber,  F  is  wave  frequency,  Fi  is  inertial  frequency,  and  * 

z  is  depth.  •  * 

* 

The  vertical  modes  W(z)  generated  by  this  code  are  in  units  of  m/sec,  and  * 
the  wavenumbers  k**2  are  in  units  of  ( radians/m) **2 .  The  normalization  * 
of  W(z)  is  such  that  the  integral  from  bottom  to  surface  of  Potential  +  * 
Kinetic  Energy  is  given  by  * 

* 

Int[ PE+KE ]dz  -  Int[W(z)*{N(z)**2  -  Fi**2}/{F**2  -  Fi**2}]dz  * 

-  No**2  *  b**3  ,  * 

* 

where  b  *  1300  meters,  and  No  is  the  scale  Vaisala  frequency  *  * 

3  cph  *  (2*pi/3600)  ( rad/cycle )*( hr/sec )  -  5.24*10-4  rad/sec.  * 

* 

To  produce  the  nondimensional  normal  modes  Z(z)  found  in  Garrett  and  * 

Munk  (1972),  one  must  divide  W(z)  by  b*F,  where  b  -  1300  m,  and  * 

F  *  frequency  in  radians  per  second.  * 

* 

_ _ _ 

David  Rubenstein,  Science  Applications  International  Corp.,  Nov.  1987  * 

Version  for  Lahey  77  Fortran,  IBM-PC  * 

- - - - - - - - — - — _ _ _ — - - ★ 

* 

Input  Parameters  * 

* 

NMODES  Number  of  modes  desired  (Integer*4)  * 

F  Wave  Frequency,  in  cph  (Real*4)  * 

NBV  Number  of  points  in  BV  profile  (Integer*4)  * 

ZT  Depths  of  BV  frequencies,  in  meters  (Real*4  array  of  length  NBV)  * 

BVT  Set  of  BV  frequencies,  in  cph  (Real*4  array  of  length  NBV)  * 

NZ  Preliminary  estimate  for  number  of  points  required  in  * 

vertical  modes  (Integer*4)  * 

LAT  Latitude,  in  degrees  (Real*4)  * 

EPSLON  Relative  accuracy  required  for  determination  of  K**2  (Real*4)  * 

Recommended  value:  0.001  * 

IPRINT  Print  parameter.  Set  «  0  for  no  diagnostics.  * 

* 

Output  parameters  * 

* 

NZ  Actual  number  of  points  in  computed  vertical  modes  (Integer*4)  * 

K  Wavenumber,  in  Radians/meter  (Real*4  array  of  length  NMODES)  * 

Z  Depths,  in  meters,  corresponding  to  vertical  velocity  modes  * 

(Real*4  array  of  size  NZ )  * 

WM  Vertical  velocity  modes,  in  m/sec  (Real*4  2-D  array  of  size  * 

NZ  X  NMODES)  * 

* 

Restrictions:  Maximum  value  for  NZ  is  MAX,  and  maximum  value  for  NMODES  * 
is  MODEMAX,  both  of  which  are  set  in  the  parameter  statement.  * 

* 

Suggestion  on  usage:  Call  this  subroutine  (MODESUB)  once  for  each  frequency* 
desired,  but  start  with  the  highest  frequency  and  work  downward.  This  * 


nnonnoo  non 


C  subroutine  tests  for  sufficient  resolution,  and  the  constraint  is  greatest* 
C  at  high  frequencies.  * 
C  * 


PARAMETER  (  MAX  -  8000,  MODEMAX  -  50  ) 

REAL  BV ( MAX ) ,  W(MAX),  F,  K2 ( 0 : MODEMAX ) ,  LAT,  G ( MAX ) 
REAL  Z ( MAX ) ,  BVT(NBV),  ZT(NBV),  K20LD,  K2NEW 
REAL  K2MAX,  K2MIN,  WM ( MAX , 0 : MODEMAX ) ,  K ( 0 : MODEMAX ) 

LOGICAL*l  FIRSTGO 

DATA  BDEP/1 300 . 0/,  NRES/5/ 


K20LD 

K2NEW 

K2MAX 

K2MIN 

BDEP 

NRES 


0 

0 

0 

0 

1300.0 

5 


DEPTH  -  ZT(NBV) 

PI  -  4 . *ATAN( 1 . ) 

DEGRAD  -  PI/180. 

FI  -  SIN( DEGRAD*LAT)/12 . 0 

IF  (  NMODES*NRES  . GT .  NZ  )  THEN 
NZ  -  NRES *NMODES 

I F ( I  PRINT  .GE.  1)  WRITE( 11,25)  NZ 
FORMAT ( '  NZ  has  been  adjusted  to  -  ',i5) 
ENDIF 


*  TOP  OF  MODES  LOOP  * 


CONTINUE 

IF  (  NZ  .GT.  MAX  )  THEN 
WRITE(11,30)NZ,MAX 
WRITE (6, 30 )NZ, MAX 

FORMAT < '  NZ  -  ',i5,'  is  >  MAX  -  ',i 4, 

'  Decrease  NMODES  or  increase  MAX.  Program  aborting.') 

STOP  '  ERROR  -  NZ  TOO  SMALL  TO  RESOLVE  DE  ' 

ENDIF 

CALL  INTERP  (  NBV,  ZT,  BVT ,  NZ,  DEPTH,  Z,  BV  ) 

DZ  -  DEPTH/( NZ-1 ) 


******** 


Test  for  resolution  between  turning  points.  NRES  is  the  minimum  number  * 
of  vertical  sampling  intervals  per  mode.  * 


******** 


DO  60  J  -  1,  NZ 

G(J)  -  (BV(J)**2  -  F**2)  /  (F**2  -  FI **2  ) 


*****  (Bz)  * 


non  nnn  non  non 


B ( BV, J , F , FI ) 


G(  J) 

60  continue 

CALL  TURN(  G,  NZ ,  JA,  JB,  JM  ) 

IF  (  NMODES*NRES  .GT.  JB-JA  )  THEN 

IF ( IPRINT  .GE.  1)  WRITE (11,70)  NMODES,  NRES ,  JB-JA 
70  FORMAT { '  NMODES  -  ',i3,'  *  ',i3,'  >  JB-JA  -  ',i3,/, 

1  '  Region  between  turning  points  insufficiently  resolved.') 

NZ  *  NZ  *  1.25 

I F ( I  PRINT  .GE.  1)  WRITE{ 11,25)  NZ 
GO  TO  28 
ENDIF 


80 


DO  80  J  -  1,  NZ 

G( J )  -  b(bv,j,f,f:) 

CONTINUE 


*  (BZ)  * 


CALL  TURN (  G,  NZ ,  JA,  JB,  JM  ) 

CALL  AVGINT  (  G,  NZ ,  JA,  JB,  DZ ,  GAVG  ) 
AFACTOR  -  ( PI /GAVG )  **2 
II  -  1 
N  -  NZ 


********************** 

*  Loop  through  modes  * 
********************** 

DO  400  M  -  0,  NMODES 

************************ 

*  First  guess  for  k**2  * 
************************ 

I F ( FIRSTGO )  THEN 

K20LD  -  AFACTOR* (M+l. 5 )**2 

ELSE 

K20LD  -  K ( M ) * *2 

END  IF 

IF  ( IPRINT. GE.l )  WRITE( 11 ,*)' START  ITERATION:  K20LD  -  ' , K20LD 

K2MAX  -  K2OLD*40.0 
K2MIN  -  K2OLD/40 . 0 

IF  (  M  .GT.  0  )  K2MIN  -  K2(M-1) 

ITERATE  -  0 
NUMBER  -  0 
K2NEW  »  K2MIN 

************************* 

*  TOP  OF  ITERATION  LOOP  * 
************************* 

100  CONTINUE 

I F ( I  PRINT .GE.l ) WRITE ( 11 , * ) 

IF  (  ( K2MAX-K2MIN)/K2MAX  .LT.  EFSLON  )  THEN 

IF( IPRINT. GE.l )  WRITE( 11 ,*) 'Converged:  k2min , k2max- ' , 

1  K2MIN , K2MAX 

GO  TO  115 
ENDIF 


n  n  n  o 


ITERATE 


ITERATE  +  1 


CALL  NUMEROV  (  M,  11,  N,  JA,  JB,  JM,  G,  W,  DZ , 

1  IPRINT,  ICOUNT,  ICROSS ,  K20LD ,  K2NEW  ) 

IF  (  I  PRINT . GE . 1  .OR.  MOD ( ITERATE , 20 ). EQ . 0  )  THEN 

WRITE ( 11,*  )  ' ITERATE ,M, ICOUNT , K20LL , K2NEW, K2MIN , K2MAX  - 
WRITE ( 11 , 110 ) ITERATE,M, ICOUNT, K20LD, K2NEW, K2MIN, K2MAX 
110  FORMAT ( lx,l6,2l4,2DlS.4,5X,2Dl4.4) 

ENDIF 

IF  (  ICOUNT  .NE.  M  )  THEN 
IF  (  ICOUNT  .LT.  M  )  THEN 
IF  (  ICROSS  .EQ.  0  )  THEN 

K2MIN  -  AMAX1 ( K2MIN , K20LD ) 

ELSE 

K2MIN  -  AMAXl (K2MIN,0.5*( K2MIN+K20LD ) ) 

ENDIF 

ELSE 

K2MAX  -  AMIN1 ( K2MAX , K20LD ) 

ENDIF 

IF  (  ICROSS  .EQ.  1  )  THEN 
NUMBER  -  NUMBER  +  1 
DELTAl  -  0. 5*( K2MAX+K2MIN)  -  K20LD 
DELTA2  -  K20LD* ( ( 2 . 0*M+1 . )/( 2 . 0*ICOUNT+1 )  -  1.0) 

IF  (  ABS( DELTAl)  . GT .  2 . *ABS ( DELTA2 )  )  THEN 

K20LD  -  K20LD  +  DELTA2 
ELSE 

K20LD  -  K20LD  +  DELTAl 
ENDIF 
GO  TO  100 
ENDIF 


IF  (  ICOUNT  .LT.  M  )  THEN 

K20LD  -  0 . 5* ( K2MAX+K20LD ) 
ELSE 

K20LD  -  0 . 5* ( K2MIN+K20LD ) 

ENDIF 
GO  TO  100 
ENDIF 


IF  (  ABS ( ( K20LD-K2NEW ) /K2NEW )  .GT.  EPSLON  )  THEN 
IF  (  ICROSS  .EQ.  1  )  GO  TO  100 
IF  (  K2NEW  .GT.  K20LD  )  THEN 
K2MIN  -  K20LD 
ELSE 

K2MAX  -  K20LD 

ENDIF 

K20LD  -  K2NEW 
GO  TO  100 
ENDIF 


IF  (  IPRINT  .GE.  1  )  THEN 
WRITE (11, *  ) 

WRITE( 11 ,*) 'CONVERGED:  K20LD ,  K2NEW- ' , K20LD, K2NEW 
ENDIF 

*********************************** 

*  Pad  with  zeros  if  bottom  or  top  * 

*  were  brought  in  * 

*********************************** 


non  nnnn  non 


115  CONTINUE 

IF  (  II  .GT.  1  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE( 11 , *  )  '  ZERO-Pad:  11  -  ',1 
DO  135  I  -  1,  11-1 
W( I )  -  0. 

135  CONTINUE 

ENDIF 

IF  (  NZ  .GT.  N  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE( 11 , * ) '  ZERO-Pad:  N,  NZ  -  ' 
DO  140  I  *  N+l ,  NZ 
W(I)  -  0. 

140  CONTINUE 

ENDIF 

*  NORMALIZE  W 

SUM  -  0. 

SUM2-  0. 

DO  160  J  -  2,  NZ 

QT2  -  ( BV ( J ) *  *  2  -  FI  *  *2  )  /  (F**2  -  FI**2) 

QTl  -  ( BV ( J-l ) **2  -  FI  *  *  2 )  /  ( F*  *  2  -  FI**2) 

WT2  *  b(bv,j  ,f,fi) 

WTl  -  b( bv, j-l , f , f i ) 

SUM  -  SUM  +  0.5* ( WTl*W( J-l ) **2  +  WT2*W( J ) **2 ) *DZ 
SUM2-  SUM2+  0.5* ( WT1+WT2 ) *DZ 
160  CONTINUE 


ANORM  *  SQRT (ABS(1. 0/SUM ) ) 

WM ( 1 , M )  -  0 . 

WM ( NZ , M )  -  0. 

DO  180  J  =  2 ,  NZ-1 

WM (  J  ,  M  )  -  ANORM*W { J ) 

180  CONTINUE 

K2(M)  -  K2NEW 
K ( M )  -  SQRT ( K2 ( M ) ) 

IF  (  IPRINT  .GE.  1  )  THEN 

WRITE ( 11 ,  *)' FOUND  MODE  #',M 

WRITE (11,*) 'Frequency- ',f,'  K**2  -  ',K2NEW 

IF(  IPRINT. GE. 2)  write(  11,200)  (wm(  i  ,m) ,  i  -  l,*nz) 

200  FORMAT ( IX, 6F12 . 7  ) 

ENDIF 

*************************** 

*  Adjust  afactor  for  next  * 

*  higher  mode  * 

****************)********** 

AFACTOR  -  K20LD/( M+l . 5 ) **2 

********************** 

*  END  NMODES-LOOP,  M  * 
********************** 

400  CONTINUE 


N ,  NZ 


*  *  * 
* 

*  *  * 


RETURN 

END 


non  non  non  onno 


SUBROUTINE  TURN  (  G,  NZ ,  JA,  JB,  JM  ) 


SUBROUTINE  TURN 


REAL  G ( NZ ) 

*  FIND  MAXIMUM  * 

JM  -  1 
GMAX  -  G  ( 1 ) 

DO  10  I  *  2,  NZ 

IF  (  G( I )  .GT.  GMAX  )  THEN 
JM  -  I 
GMAX  -  G ( I ) 

ENDIF 

CONTINUE 

IF  (  JM  .LE.  2  )  THEN 

IF  (  G(2) .GT.0.25*  GMAX  )  THEN 
JM  -  3 
ELSE 

write (11,*)'***  Peak  too  close  to  surface.  Increase  NZ.*** 
WRITE( 11 , * ) ' jm  -  ',jm,'  gmax»' ,gmax , '  g:' 

WRITE (11,*) (g(i) ,i«l,nz) 

WRITE (  6  ,  *  ) '  *  *  *  Peak  too  close  to  surface.  Increase  NZ.***' 
WRITE( 6, * ) ' jm  -  ',jm,'  gmax= ' , gmax , '  g:' 

write ( 6,*)(g(i),i-l,nz) 

STOP  'ERROR  -  PEAK  TOO  CLOSE  TO  SURFACE' 

ENDIF 

ENDIF 


*  Find  upper  turning  point  * 


DO  20  I  -  JM,  1,  -1 

IF  (  G( I )  .GT.  0.  )  JA 
CONTINUE 


DO  30  I  -  JM,  NZ 

IF  (  G( I )  .GT.  0.  )  JB 
CONTINUE 


*  Find  lower  turning  point  * 


RETURN 

END 


o  o  n  o  o 


SUBROUTINE  AVGINT  (  G,  NZ ,  JA,  JB ,  DZ ,  GAVG  ) 


Title  subroutine  avgint 

Purpose  Integrate  g(z)  from  index  j  -  ja  to  jb,  and  get  average 


★ 

★ 

★ 

* 

★ 


REAL  G ( NZ ) 

GAVG  -  0. 

DO  20  J  -  JA,  JB 

GAVG  -  GAVG  +  SQRT ( ABS ( G ( J ) ) ) 
20  CONTINUE 

GAVG  «=  GAVG*DZ 

RETURN 

END 


non  o o n n o  non  oonn 


SUBROUTINE  NUMEROV  (M,  II,  N,  JA,  JB,  JM,  G,  W,  DZ  , 

1  IPRINT,  ICOUNT,  ICROSS ,  K20LD ,  K2NEW) 


* 

Title  subroutine  avgint  * 

* 


1 


PARAMETER  (  MAX 
REAL  G ( N ) ,  W(N) , 
DOUBLE  PRECISION 
DOUBLE  PRECISION 

DOUBLE  PRECISION 
DATA  S/1./ 


8000  ) 

K20LD,  K2NEW 

T ( MAX ) ,  PHI P( MAX 

S,  FACT,  PHI  2 , 
BlP,  B2P ,  BlM, 

PHIPPR, PHIMPR 


)  , PHIM( MAX 

AlP,  A2P, 
B2M 


) 

AIM, 


A2M, 


*  Initialize  end  points  * 


10  CONTINUE 

PHIM(Il)  -  0. 

PHIM( I 1+1 )  *  S*D2 
PHIP(N)  -  0. 

IF  (  MOD ( M , 2 )  .EQ.  0  )  THEN 
PHIP(N-l)  -  S*DZ 
ELSE 

PHIP(N-l)  -  -S*DZ 
ENDIF 

*  Icross  is  a  flag,  which  is  set  -  1  * 

*  if  there  is  a  zero-crossing  at  the  * 

*  match  point,  but  no  sign  match  * 

ICROSS  -  0 
ICOUNT  -  0 

FACTOR  -  (DZ**2)*K20LD/12. 

DO  20  I  -  II,  N 

T ( I  )  -  -FACTOR  *  G ( I ) 

20  CONTINUE 

JBOT  -11+2 

DO  40  J  -  JBOT,  JM  +  2 

PHIM(J)  -  (  (2.  +  10.*T( J-l) )*PHIM( J-l)  + 

1  ( T ( J-2 )  -  1. )*PHIM( J-2)  )  /  (l.-T(J)) 

I F (  J.LE.JM  .AND.  PHIM{ J-l ) *PHIM( J ) . LE . 0 .  )ICOUNT  -  ICOUNT+1 

*  Bring  in  top  if  exponential  * 

*  growth  is  sufficiently  strong* 


ARG  -  (ABS(PHIM( J) )+ABS(PHIM( J-l ) ) )  / 

( ABS{ PHIM( 1 1  +  1 )  )+ABS( PHIM(  11  +  2 )  )  ) 

IF  (  ARG  .GT.  1.E12  )  THEN 
IBOT  -  II  +  1 
DO  30  I  =  J,  IBOT,  -1 

ARG  -  ( ABS { PHIM ( J ) ) +ABS (PHIM(J-l)))  / 

(ABS(PHIM(I) ) +ABS ( PHIM( 1-1 ) ) ) 

IF  (  ARG  .GT.  1.E6  )  THEN 
II  *  I 
GO  TO  10 
ENDIF 
CONTINUE 
ENDIF 

IF  (  ICOUNT  .GT.  M  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE( 11 ,*)' ICOUNT  >  M  IN  PHIM' 

GO  TO  600 
ENDIF 

CONTINUE 

JTOP  -  N  -  2 

DO  60  J  *  JTOP,  JM-2,  -1 

PHIP(J)  =  (  (2.  +  10.*T( J+l) )*PHIP( J+l)  + 

( T ( J  +  2  )  -  1  .  ) *PHIP< J  +  2  )  )  /  (l.-T(J)) 

I F (  J.GE.JM  .AND.  PHIP ( J+l ) *PHIP ( J ). LE . 0 .  )ICOUNT  -  ICOUNT+1 

*  Bring  in  bottom  if  exponential 

*  growth  is  sufficiently  strong 


ARG  -  (ABS ( PHIP( J )  ) +ABS (PHIP(J  +  1)  )  )  / 

( ABS ( PHI P ( N-l ) ) +ABS ( PHIP ( N-2 ) ) ) 

IF  (  ARG  .GT.  1.E12  )  THEN 
I  TOP  -N-l 
DO  50  I  -  J,  ITOP 

ARG  -  ( ABS ( PHI P ( J ) ) +ABS (PHIP(J+1) ) )  / 

( ABS ( PHIP ( I )  ) +ABS ( PHIP( 1  +  1 )  )  ) 

IF  (  ARG  .GT.  1.E6  )  THEN 
N  -  I 
GO  TO  10 
ENDIF 
CONTINUE 
ENDIF 

IF  (  ICOUNT  .GT.  M  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE( 11 ,*)' ICOUNT  >  M  IN  PHIP' 
GO  TO  600 
ENDIF 

CONTINUE 


*  Does  zero-crossing  occur  at 

*  match-point? 


IF  (  PHIP( JM) *  PHI M ( JM)  .LE.  0.0  )  THEN 
ICROSS  -  1 
ICOUNT  -  ICOUNT  +  1 

IF  (  IPRINT  .GE.  1  )  WRITE! 11 ,*)' zero-crossing  at  j-jm-', 

jm,'  i 'ount-' , ICOUNT 


c 

c 

c 


IF  (  ICOUNT  .NE.  M  )  THEN 

IF  (  IPRINT  .GE.  1  ) WRITE (11,*) ' i count  <>  m  at  match  point' 
GO  TO  600 
END1  F 

*  Look  for  sign-match  * 


C 

C 

C 

C 

C 

C 


IF  (  PHI  P  (  JM-  1)*PHIM(JM)  .  GT  .0.0  .OR. 

1  PH1P( JM-2)*PHIM( JM) .GT.0.0  .OR. 

2  PHIP(JM) *PHIM( JM+1 ) . GT .0.0  .OR. 

3  PHIP( JM)*PHIM( JM+2) .GT.0.0  )  THEN 

JM1  -  JM  +  0.5*(JB-JA)/(M+2. ) 

JM2  *  JM  -  0 . 5* ( JB-JA)/( M+2  .  ) 

IF  (  JMl  .GT.  JA  .AND.  JMl  .LT.  JB  )  THEN 
JM  -  JMl 
ELSE 

IF  (  JM2.GT.JA  .AND.  JM2.LT.JB  )  THEN 
JM  -  JM2 
ELSE 

JM  -  0.5*( JM  +  JB) 

ENDIF 

ENDIF 

IF  (  IPRINT  .GE.  1  )  WRITE (11,*) 

1  'Sign  match  found.  New  jm-',JM 

GO  TO  700 
ELSE 

ICOUNT  -  M  -  1 
GO  TO  600 

******************* 

*  End  Sign-Match  * 
******************* 

ENDIF 

********************** 

*  End  Zero  Crossing  * 
********************** 

ENDIF 


C 

C 

c 


IF  (  ICOUNT 


.NE.  M  /  GO  TO  600 


******************** 
*  Early  return  * 


C 

c 

c 

FACT  -  PHI P ( JM ) /PHIM( JM ) 


*  Adjust  phi  by  a  factor  * 


70 


80 


C 

C 

C 


100 


IF  (  FACT  .GT 
DO  70  J  - 
PHI P ( J ) 
CONTINUE 
ELSE 

DO  80  J  - 
PHIM ( J ) 
CONTINUE 
ENDIF 


.  1.  )  THEN 

JM-2  ,  N 

-  PHI P ( J ) /FACT 


2,  JM+2 

-  FACT*PHIM( J ) 


*  Integrate  phi**2  * 


PHI2  -  0. 

DO  100  J  -  2,  JM 

PHI 2  -  PHI 2  +  G(J-1)*PHIM(J-1)**2+G(J)*PHIM(J)**2 
CONTINUE 


N 


DO  110  J 


JM+1  , 


non  nno  non 


110 


120 


140 


600 

620 

640 

700 


PHI2  -  PHI2  +  G ( J-l ) *PH 1 r ( J-l ) *  *2+G (J)*PHIP(J)*+2 
CONTINUE 


PHI2  -  0 . 5*DZ*PHI2 


*  Compute  phip'  and  phim'  * 
*************************** 


A1P 

A2P 

AIM 

A2M 

BlP 

B2P 

BlM 

B2M 


0.5*(PHIP( JM+1) -PHI P( JM-1) ) 
0.5*(PHIP( JM+2)-PHIP( JM-2) ) 
0. 5* (PHIM( JM+1) -PHIM (JM-1) ) 
0.5*{PHIM( JM+2)-PHIM( JM-2) ) 


T( JM+1)*PHIP{ JM+1) 
T ( JM+2 ) *PHIP( JM+2 ) 
T( JM+1 ) *PHIM( JM+1 ) 
T( JM+2)*PHIM( JM+2) 


T( JM-1 ) *PHIP( JM-1 ) 
T ( JM-2 ) *  PHI P ( JM— 2 ) 
T( JM-1)*PHIM( JM-1) 
T( JM-2 ) *PHIM( JM-2 ) 


PHIPPR  *  ( 16 ./( 21 . *DZ ) ) *  (  -A1P  +  ( 37 ./32 . ) *A2P 

-  ( 17 ./40 . ) *B2P  ) 

PHIMPR  -  ( 16 ./( 21 . *DZ ) ) *  (  -AIM  +  ( 37 ./32 . ) *A2M 

-  (17./40. )*B2M  ) 


( 37. /5. ) *B1P 
(37. /5. ) *BlM 


DO  120  J 
W(J)  > 
CONTINUE 

DO  140  J 
W(J)  . 
CONTINUE 


■  1,  JM 
PHIM( J ) 


•  JM+1,  N 
PHIP( J ) 


K2NEW  «  K20LD  -  W( JM )*( PHIPPR 
RETURN 


*  Get  new  trial  value  for  k**2  * 
PHIMPR)  /  PHI2 


*  Early  return  * 


CONTINUE 

DO  620  J 
W(J)  > 
CONTINUE 

DO  640  J 
W(J)  ■ 
CONTINUE 

K2NEW 


»  1 ,  JM 
PHIM ( J ) 


>  JM+1,  N 
PHIP ( J ) 


1 .E-20 


RETURN 

END 


ononnnnonoonononnoo 


SUBROUTINE  INTERP  (  N,  Z,  X,  NX,  2 TOTAL ,  ZI,  XI  > 


* 


Subroutine  Interp  * 

* 

Interpolate  function  x(z),  from  depth  z-0  to  z-ztotal.  * 

★ 


Input  parameters:  * 

* 


N 

Length  of  arrays  X  and  Z 

★ 

Z 

Real*4  array  of  length  N 

★ 

X 

Real*4  array  of  length  N 

* 

NI 

Length  of  desired  output  arrays  ZI  and  XI 

★ 

ZTOTAL 

Total  depth  to  which  interpolated 

output  is 

desired 

★ 

* 

Output 

parameters : 

* 

* 

ZI 

Regular  (Real*4)  interval  array. 

ranging  from  0  to  ZTOTAL, 

★ 

of  length  NI 

★ 

XI 

Interpolated  values  (Real*4  array 

of  length 

NI 

★ 

* 


REAL  2(1),  X(l),  ZI(1),  XI (1) 

DZ  -  ZTOTAL/( NI-1 ) 

J  -  1 

DO  50  I  -  1,  NI 

ZI(I)  -  ( 1-1 ) *DZ 
40  CONTINUE 

IF  (  ZI(I)  .GE.  Z(J)  .AND.  ZI(I)  .LE.  Z(J+1))  THEN 
XI(I)  -  X(J)  +  ( X( J+l )-X( J )  )*(ZI(I)-Z(J)  ) 

1  /( Z ( J+l ) -Z ( J ) ) 

ELSE 

J  -  J  +  1 

IF  (  I.EQ.NI  .AND.  ABS ( Z I ( I ) -Z ( J ) ) . LE . 0 . 01  )  THEN 
ZI(I)  -  Z(J) 

XI(I)  -  X(J) 

RETURN 

ENDIF 

IF  (  J  .GT.  N  )  STOP  'J  >  N  :  ERR  IN  INTERP' 

GO  TO  40 

ENDIF 

50  CONTINUE 

RETURN 

END 


onnno  nnnnnnnnnnoononooonnononnonnnnnn 


SUBROUTINE 


PROFILE  CALC 


PROGRAM 


PROFILE  CALC 


PURPOSE 


Profiles  of  temperature,  salinity  and  Brunt-Vai sala  i 
frequency  are  computed  by  "advecting"  the  temperature  i 
and  salinity  base  profiles  by  the  caculated  displacement1 
field.  i 


AUTHOR 


K.D.  Saunders 


HISTORY 


10/27/88 


-  Begun  coding  and  testing 


INTERFACING  All  program  I/O  is  performed  via  named  common 
OUTPUT 


UNIT  FILE 


FORMAT 


DATA 


DIAGNOSTICS. LIS  ASCII 
MODELl.DAT  DIRECT 


Diagnostic  information 
OUTPUT  profiles 


Notes : 


The  "advection"  is  done  by  creating  a  starting 
of  depths  defined  by  the  base  depth  +  displacement. 
The  base  temperatures  and  salinities  are  associated 
with  this  depth  vector  and  are  then  sorted  in  order 
of  increasing  depth  and  interpolated  back  onto  the 
base  depth  vector.  The  BV  frequencies  are  then 
computed  from  the  new  T  and  S  profiles. 


IMPLICIT  NONE 
INCLUDE  ' MODELl . INC ' 

LOGICAL*l  SORTED 

REAL  Z  0 ( MAX ) , TT  0 ( MAX ) , S  0 ( MAX ) , 

1  ZINT(MAX) ,TINT(MAX) ,SINT(MAX) , 

2  BVINT ( MAX ) ,P(2) , T_TEMP ( MAX ) ,S_TEMP(MAX) , 

3  PAV , E , BVFRQ , DUM 

INTEGER  LOC  REC 


DO  510  I  -  1 , NZ 

Z0( I )  -  ZBV ( I )  +  ZD ( I ) 

ZINT(I)  -  ZBV(I) 

TTO ( I )  -  TEMP ( I , IX) 

S0(I)  -  SAL ( I , IX ) 

510  CONTINUE 

ZINT(NZ)  -  ZO(NZ) 

Z INT ( 1 )  -  Z 0 ( 1 ) 

t ********************** 

I  Make  sure  input  z's  * 
1  are  sorted  in  * 

!  ascending  order  * 


DO  520  I 


-  1  ,No 


SORTED  -  .TRUE. 


DO  530  J  -  1 , NZ-1 

I F {  Z0 ( J ) . EQ .  Z0( J+l ) )  THEN 
Z0(J+1)  -  Z0(J)+.01 
END  IF 

I F (  Z0(J).GT.  Z0 ( J+l ) )  THEN 


DUM 

■ 

Z0(  J) 

z  o  ( j) 

- 

Z  0 ( J+l ) 

Z0( J+l ) 

- 

DUM 

DUM 

« 

TT0  ( J  ) 

TT0 ( J ) 

-  TT0 ( J+l 

TT0( J+l ) 

-  DUM 

DUM 

« 

SO  ( J  ) 

SO  ( J ) 

« 

SO  ( J+l) 

S0( J+l) 

- 

DUM 

SORTED  - 

.FALSE. 

END  IF 

530  CONTINUE 

I F (  SORTED  )  GOTO  1000 

520  CONTINUE 


C 

C 

C 

1000 


C 

C 

C 


*************************** 

*  DATA  IN  ASCENDING  ORDER  * 
*************************** 

CONTINUE 

CALL  INTRPL ( 6 , NZ , Z0 , TT0 , NZ , ZINT , TINT ) 

CALL  INTRPL ( 6 , NZ , Z 0 , S 0 , NZ , ZINT , SINT ) 

************************ 

*  Compute  BV  Freqs  * 

************************ 


540 


DO  540  I  - 
T_TEMP( 1 ) 
T_TEMP{ 2 ) 
S_TEMP( 1 ) 
S  TEMP ( 2 ) 

PTl) 

P(2) 

BVINT ( I  ) 
CONTINUE 


1 , NZ-1 

-  TINT ( I ) 

-  TINT ( 1  +  1 ) 

-  SINT(I) 

-  SINTU  +  1) 

-  ZINT ( I ) 

-  ZINT( 1+1 ) 

-  BVFRQ( S  TEMP , T  TEMP , P , 2 , PAV , E ) 


BVINT ( NZ )  -  BVINT(NZ-l) 


LOC_REC  -  NX* (IT-1)  +  IX 
WRITE( 12 , rec-LOC  REC) 

l  ( zd ( i ) ,tintTi) , SINT(I) ,BVINT(I) ,1-1, NZ) 


RETURN 


100 

FORMAT ( 

'  MODIFIED  PROFILE  ',14,' 

X  -  ' , FI 0.3// 

1 

'  Z  ZD 

T  S 

BV 

110 

FORMAT ( 

5F12.3) 

120 

FORMAT ( 

///'  TIME  •  ' ,  F18 . 4 ) 

'//) 


130  FORMAT( 24X,  '  ( ' , F8 . 3 , ' ) ' , '  ( ' , F8 . 3 , ' ) '/) 

END 


nnonoonnrjonnnoonnnoooonnonnnnoononnnoono 


FUNCTION  DIST( ELAT, ELONG, SLAT, SLONG) 


PROGRAM 


DIST 


PURPOSE 


DISTANCE  IN  KM  BETWEEN  TWO  POSITIONS  ON  THE  EARTH 


HISTORY 


8/5/88 


1.  Program  written 


AUTHOR ( S ) 


K.D.  Saunders  (NOARL) 


INPUT 


SLAT 

SLON 

ELAT 

ELON 


REAL* 4 
REAL*  4 
REAL*  4 
REAL* 4 


-  STARTING  LATITUDE  IN  DEC.  0 

-  STARTING  LONGITUDE  IN  DEC.  0 

-  ENDING  LATITUDE  IN  DEC.  0 

-  ENDING  LONGITUDE  IN  DEC.  0 


OUTPUT 


DIST  -  REAL *4 


-  DISTANCE  IN  KM  BETWEEN  THE  * 
STARTING  AND  ENDING  POSITIONS  * 


Notes 

The  program  assumes  a  spherical  earth  and  uses  basic 
spherical  trigonometry. 

One  degree  of  latitude  is  assumed  to  be  111.195  km. 


IMPLICIT  NONE 

REAL  ELAT , ELONG , SLAT , SLONG , SL , EL , DL , X , DI ST 
REAL  CONV , KMPERDEG  /111 . 195/, TWOPI 


TWOPI  -  2*3.14159265 

CONV  -  3.14159265/180. 


I F (  ABS(ELAT)  .GT.  90.  .OR. 

1  ABS(SLAT)  .GT.  90.  .OR. 

2  ABS( ELONG) .GT. 180.  .OR. 

3  ABS ( SLONG ) . GT .180.  )  THEN 


DIST  -  99999.0 
RETURN 


END  IF 


EL  -  ELAT*CONV 
SL  -  SLAT* CONV 


DL  -  ABS ( ELONG-SLON^) * CONV 


IF  (DL  .GE.  TWOPI)  UL 


DL  -  TWOPI 


X  -  SIN{EL)*SIN(SL)  +  COS ( EL ) *COS ( SL ) *COS ( DL ) 

I F ( ABS ( ABS { X )  -  1.0)  .LT.  0.00001)  THEN 
DIST  -  0.0 
RETURN 
END  IF 


I F ( ABS  (X)  .GT.  1  )  THEN 
DIST  -  9999. 

WRITE (  *  ,  *  )  '  ARGUMENT  TO  ACOS  .GT.  1,  »',X 
RETURN 
END  IF 


DIST  -  KMPERDEG* ACOS ( X ) /CONV 

RETURN 

END 


oononnnononoononnnnnnoononnonnono 


SUBROUTINE  LINT ( Xl , X2 , N , X ) 


PROGRAM 
PURPOSE 
HISTORY 
AUTHOR ( S ) 


INPUT 


LINT 

LINEAR  INTERPOLATOR 

8/5/88  1.  Program  written 

K.D.  Saunders  (NOARL) 


XI  -  REAL* 4 
X2  -  REAL* 4 
N  -  INTEGER*  4 


* 

* 

* 

* 

* 

* 

* 

* 

* 

* 


OUTPUT 


X  -  real  array 


Notes 


Given  Values  Xl  and  X2 ,  computes  N  (inclusive)  points 
between  them.  I.e.  X(l)  «  Xl ,  X(N)  -  X2  with  the  rest 
evenly  spaced. 


IMPLICIT  NONE 

C  *******  PASSED  VARIABLES  ********** 

REAL  Xl , X2 , X ( * ) 

INTEGER  N 

C  *******  LOCAL  VARIABLES  *********** 


REAL  DX 

INTEGER  I 


DX  -  (X2-X1 )/(N-l ) 

DO  550  I  -  1 , N 

X (  I  )  -  ( 1-1 ) *DX  +  Xl 
550  CONTINUE 

RETURN 

END 


oononrjnnonnnooonnonnnnnononononononn 


SUBROUTINE  INTRPL ( IU,L,X,Y,N,U,V) 

************************************************************************ 

* 

INTRPL  * 

* 

INTERPOLATION  OF  A  SINGLE  VALUED  FUNCTION.  * 

THIS  SUBROUTINE  INTERPOLATES,  FROM  VALUES  OF  THE  * 

FUNCTION  GIVEN  A  ORDINATES  OF  INPUT  DATA  POINTS  IN  * 

THE  X-Y  PLANE  AND  FOR  A  GIVEN  SET  OF  X-VALUES ( ABCISSAS ) , * 
THE  VALUES  OF  A  SINGLE  VALUED  FUNCTION  Y-Y(X). 


PROGRAM 

PURPOSE 


AUTHOR 


* 
* 
* 
* 
* 
* 
★ 
* 
* 

* 


HIROSHI  AKIMA , U . S . DEPT  OF  COMMERCE , OFFICE  OF 
TELECOMMUNICATIONS,  INSTITUTE  OF  TELECOMMUNICATIONS 
SCIENCES,  BOULDER  COLO 

THIS  ALGORITHM  WAS  PUBLISHED  IN  COMM.  ACM.  15(10) 
OCT  1972 


INPUT  PARAMETERS  ARE 

IU  *  LOGICAL  UNIT  NUMBER  OF  STANDARD  OUTPUT  UNIT 


* 
* 
* 
* 
* 
* 
* 
★ 
* 
* 
* 
* 
* 
* 
* 
★ 


L 

X 

Y 

N 

U 


NUMBER  OF  INPUT  DATA  POINTS 

ARRAY  OF  DIMENSION  L  STORING  THE  X  VALUES 

(ABCISSAS)  OF  THE  DATA  POINTS  IN  ASCENDING  ORDER 

ARRAY  OF  DIMENSION  L  STORING  THE  Y  VALUES 

(ORDINATES)  OF  THE  INPUT  DATA  POINTS 

NUMBER  OF  POINTS  AT  WHICH  INTERPOLATION  OF  THE 

Y  VALUES  (ORDINATE)  IS  DESIRED 

ARRAY  OF  DIMENSION  N  STORING  THE  X  VALUES  OF  THE 
DESIRED  POINTS. 


OUTPUT  PARAMETERS 

V  -  ARRAY  OF  DIMENSION  N  WHERE  THE  INTERPOLATED  Y 
VALUES  ARE  STORED 


DIMENSION  X(1),Y(1),U(1),V(1) 

EQUIVALENCE  ( P0 , X3 ) , ( Q0 , Y3 ) , { Ql , T3 ) 

REAL  Ml , M2 , M3 , M4 , M5 

EQUIVALENCE  (UK,DX) , ( IMN , X2 , Al , Ml ) , ( IMX , X5 , A5 , M5 ) , 
1  ( J,SW,SA) , ( Y2,W2,W4,Q2) , (Y5,W3,Q3) 


C  PRELIMINARY  PROCESSING  * 


10  LO-L 


11 


LMl-LO-1 

LM2-LM1-1 

LP1-L0+1 

NO-N 

I F (  LM2  .LT.  0  ) 

I F (  NO  .LE.  0  ) 

DO  11  1-2, L0 

I F ( X ( I -1 ) -X ( I ) ) 
CONTINUE 


GO  TO  90 
GO  TO  91 

11,95,96 


IPV  -  0 


c 

c 

c 

DO  80  K  -  1 ,  NO 
UK  -  U { K ) 

C 

C 

C 

20  I F ( LM2  .EQ.  0)  GO  TO  27 

I F ( UK  .GE.  X ( L0 ) ) GO  TO  26 
IF( UK  .LT.  X( 1 ) )  GO  TO  25 

IMN- 2 
I MX  -  L0 


21 

I  -  ( IMN+IMX )/2 

I F ( UK  .GT.  X{ I ) ) 

GO  TO  23 

22 

I  MX  -  I 

GO  TO  24 

23 

IMN  -  I  +  1 

24 

I F (  IMX  .GT.  IMN) 
I  -  IMX 

GO  TO  30 

GO  TO  21 

25 

1-1 

GO  TO  30 

26 

I  -  LPl 

GO  TO  30 

27 

I=*2 

C 

C 

C 

30  I F ( I  .EQ.  IPV)  GO  TO  70 

IPV  -  I 


*  MAIN  DO  LOOP 


*  ROUTINE  TO  LOCATE  DESIRED  POINT  * 


*  CHECK  IF  I  -  IPV  * 


C 

C 

C 

C 

C 


*  ROUTINES  TO  PICK  UP  NECESSARY  X 

*  AND  Y  VALUES  AND  TO  ESTIMATE 

*  THEM  IF  NECESSARY 


IF(J.EQ.l)  J-2 
IF(J.EQ.LPl)  J-L0 

X3  -  X(J-l) 

Y3  -  Y(J-l) 

X4  -  X(J) 

Y4  -  Y ( J  ) 

A3  -  X4-X3 

M3  -  (Y4-Y3)/A3 
I F ( LM2  .EQ.  0)  GO  TO  43 
I F ( J  .EQ.  2)  GO  TO  41 


X2  -  X( J-2  ) 
Y2  -  Y ( J-2 ) 


A2  -  X3-X2 
M2  -  (Y3-Y2)/A2 

IF(J  .EQ.  LO)  GO  TO  42 

41  X5  -  X(J+1) 

Y5  *  Y( J+l ) 

A4  *  X5-X4 
M4  -  (Y5-Y4)/A4 

I F ( J  .EQ.  2)  M2  -  M3  +  M3  -  M4 
GO  TO  45 

42  M4  «  M3+M3-M2 

GO  TO  45 

43  M2  -  M3 

45  I F  ( J  .LE.  3)  GO  TO  46 

Al  =  X2-X(J-3) 

Ml  -  ( Y2-Y ( J-3 ) ) /Al 

GO  TO  47 

46  Ml  *  M2+M2-M3 


47  I F ( J  .GE.  LMl )  GO  TO  48 
AS  -  X( J+2 )  -  X5 

M5  -  ( Y ( J+2 )  -  Y5)/A5 
GO  TO  50 

48  M5-M4+M4-M3 


C 

C 

C 


★★★★★★★★★★★★★★★★★★★★★★★★★★★A* 

*  NUMERICAL  DIFFERENTIATION  * 


50  IF(  I  .EQ.  LPl )  GO  TO  52 

W2  -  ABS ( M4-M3 ) 

W3  -  ABS ( M2-M1 ) 

SW  -  W2+W3 

IF(SW  .NE.  0.0)  GO  TO  51 
W2  -  0.5 
W3  -  0.5 
SW  »  1.0 


51 


52 


T3  -  (W2*M2+W3*M3 )/SW 

I F ( I  . EQ.  1 )  GO  TO  54 

W3  -  ABS ( M5-M4 ) 

W4  -  ABS ( M3-M2 ) 

SW  -  W3+W4 


I F ( SW  .NE.  0.0)  GO  TO  53 


W3  -  0.5 
W4  -  0.5 
SW  -  1.0 


T4«(W3*M3+W4*M4 )/SW 

I F ( I  .NE.  LPl )  GO  TO  60 
T3  -  T4 
SA  *  A2  +  A3 

T4  -  0 . 5* ( M4+M5-A2* ( A2-A3 ) * ( M2-M3 )/( SA*SA) ) 
X3  -  X4 


53 


54 


C 

C 

C 


Y3 

- 

Y4 

A3 

- 

A2 

M3 

m 

M4 

GO 

TO  6  0 

T4 

- 

T3 

SA 

m 

A3+A4 

T3 

m 

0 . 5* ( M1+M2 

X3 

m 

X3  -  A4 

Y3 

m 

Y3  -  M2  *A4 

A3 

m 

A4 

M3 

m 

M2 

)  * ( M3-M4 )/( SA*SA) ) 


*  DETERMINATION  OF  THE  COEFICIENTS  * 
************************************ 


60 


Q2  -  (  2 . 0M M3-T3 ) +M3  -  T4)/A3 
Q3  -  (-M3-M3+T3+T4)/(A3*A3) 


C 

C 

C 

70  DX  -  UK-PO 


************************************ 

*  COMPUTATION  OF  THE  POLYNOMIAL  * 
************************************ 


80 


V ( K )  -  QO+DX* ( Ql+DX* ( Q2+DX*Q3 ) ) 


RETURN 


C 

C 

C 


*  ERROR  EXITS  * 


90 


WRITE ( IU, 2090 ) 
GO  TO  99 


91 

WRITE( IU, 2091 ) 
GO  TO  99 

95 

WRITE ( IU, 2095 ) 
GO  TO  97 

96 

WRITE ( IU, 2096 ) 

97 

WRITE ( IU, 2097 ) 

I,X(  I 

99 

WRITE ( IU, 2099 ) 
RETURN 

O 

2 

o 

►J 

2090 

FORMAT ( IX,  ' 

★  ★  ★  L 

-  1  OR  LESS'/) 

2091 

FORMAT ( IX, ' 

it*  it 

-  0  OR  LESS'/) 

2095 

FORMAT ( IX, ' 

***  IDENTICAL  X  VALUES'/) 

2096 

FORMAT ( IX, ' 

***  x 

VALUES  OUT  OF  SEQUENCE'/) 

2097 

FORMAT( IX, ' 

I-' 

,I7,10X, 'X(I)  = ' , El  2 . 3/ ) 

2099 

FORMAT( IX, ' 

I-' 

, 17 , 10X, 'N  «' ,17/ 

*1X, ' ****ERROR  DETECTED  IN  ROUTINE  INTRPL* ******'// ) 
END 


no no  onoooononnonooooonoonoonoono 


FUNCTION  BVFRQ(S,T,P,NOBS,PAV,E) 


* 


PROGRAM  BVFRQ 

PURPOSE  COMPUTES  B runt-Vai sala  frequency  in  CPH  * 

AUTHOR  R.  MILLARD,  WOODS  HOLE  OCEANOGRAPHIC  INSTITUTION 

NOTES: 


USES  1980  EQUATION  OF  STATE 


UNITS: 

PRESSURE  P0 

TEMPERATURE  T 

SALINITY  S 

BOUYANCY  FREQ  BVFRQ 
N**2  E 


DECIBARS 

DEG  CELSIUS  (IPTS-68) 
( IPSS-78  ) 

CPH 

RADIANS/SECOND 


CHECKVALUE:  BVFRQ-14 . 57836  CPH  E=6 . 4739928E-4  RAD/SEC. 

S ( 1 ) =35 . 0  ,  T( 1 ) *5 . 0  ,  P(l)-1000.0 
S ( 2 )  =  35 . 0  ,  T ( 2 )  =  4 . 0  ,  P(2)=1002.0 
****** *  *N0TE  RESULT  CENTERED  AT  PAV-1001.0  DBARS  ********** 
JULY  12  1982 

COMPUTES  N  IN  CYCLES  PER  HOUR,  AND  E=N**2  IN  RAD/SEC**2 
AFTER  FORMULATION  OF  BRECK  OWEN'S  &  N.P.  FOFONOFF 


* 

★ 


* 

* 

* 

it 

* 

it 

it 


it 

it 


it 

it 

it 

it 

it 

it 

it 

it 


it 


IMPLICIT  NONE 
REAL  P(l) ,T(1) ,S(1) 

REAL  E  ,  BVFRQ  ,  CXX ,  CX ,  CX Y ,  CY  ,  PAV ,  DATA ,  V3  5 0 P  ,  V*3AR , 

1  S IG , DVDP , AO 

REAL  S VAN, THETA 

INTEGER  NOBS , K 

EXTERNAL  SVAN , THETA 


E  m  0.0 
BVFRQ  *  0.0 

I F ( NOBS . LT . 2 )  RETURN 

CXX  *  0.0 
CX  -  0.0 
CXY  -  0.0 
CY  «  0.0 

*  COMPUTE  LEAST  SQUARES  ESTIMATE  OF  * 

*  SPECIFIC  VOLUME  ANAMOLY  GRADIENT  * 

DO  20  K=1 , NOBS 
CX  =  CX+P ( K ) 

20  CONTINUE 

PAV-CX/NOBS 

DO  35  K=1 , NOBS 

DATA  =  SVAN (  S  (  K  )  , THETA ( S(K),T(K),P(K), PAV ) , PAV ,SIG)*1.0E-8 


CXY  -  CXY+DATA* ( P ( K ) -PAV ) 

CY  -  CY+DATA 
CXX  -  CXX+ ( P ( K ) - PAV )  *  *  2 
35  CONTINUE 

IF(CXX.EQ.O.O)  RETURN 

AO  -  CXY/CXX 

V350P  -  ( 1 ./( SIG+1000 . ) )-DATA 

VBAR  -  V350P+CY/NOBS 

DVDP  =  AO 

IF( VBAR.EQ. 0 . 0 )  RETURN 

E  -  - . 96168 42 3E-2 *DVDP/( VBAR ) *  * 2 
BVFRQ  =  572 . 9  578  *S IGN ( SQRT ( ABS ( E ) ) , E ) 


RETURN 

END 


FUNCTION  GRADY ( Y , P , NOBS , PAV , YBAR ) 


C  FUNCTION  COMPUTE  LEAST  SQUARES  SLOPE  'GRADY'  OF  Y  VERSUS  P  * 
C  THE  GRADIENT  IS  REPRESENTIVE  OF  THE  INTERVAL  CENTERED  AT  PAV  * 
C  * 
C  COMPUTE  GRADIENT  OF  Y  VERSUS  P  * 
C  JULY  15  1982  * 


REAL  P(l) , Y ( 1 ) 

GRADY  *  0.0 

AO  *  0.0 

CXX  =0.0 

CX  =0.0 

CXY  =  0.0 

CY  =0.0 

IF(NOBS.LE.l)  GO  TO  30 

DO  20  K=1 , NOBS 
20  CX  =  CX+P ( K ) 

PAV  =  CX/NOBS 

DO  35  K=1 , NOBS 

CXY-CXY+Y ( K ) * ( P ( K ) -PAV ) 
CY  =CY+Y(K) 

CXX=CXX+{  P ( K ) -PAV) **2 
35  CONTINUE 

IF(CXX.EQ.O.O)  RETURN 

A0  =  CXY/CXX 
YBAR  =  CY/NOBS 

30  CONTINUE 


GRADY  =  A0 


RETURN 

END 


FUNCTION  B  (BV,J,F,FI) 

C  * 


c 

FUNCTION 

B 

* 

c 

* 

c 

PURPOSE 

Weighting  function  in  eigenvalue/eigenfunction  equation 

* 

c 

W' '  +  k 2  B ( z ) 

W  *  0 . 

* 

* 

C 

c 

Author 

K.D.  Saunders 

★ 

c 

* 

c 

r 

History- 

11/18/88 

Begun  Coding 

* 

* 

C 

Parameters 

* 

C 

BV ( * )  Real*4 

Array  of  Brunt-Vaisala  frequencies. 

★ 

c 

J  Int*4 

Index  to  BV  (  z  *  (j-l)*dz  ) 

* 

c 

F  Real*4 

Frequency 

* 

c 

FI  Real*4 

Inertial  Frequency 

* 

c 

★ 

c 

Notes 

In  this  implementation, 

★ 

c 

r * 

B  =  ( BV ( j ) **2- 

f **2 )/( F**2-f i *  *2  )  . 

* 

* 

L 

c 

This  is  not  especially  useful  now,  but  will  be  when  it 

* 

c 

becomes  necessary  to  include  current  shear. 

* 

+ 

********************************************************** 

IMPLICIT 

NONE 

REAL 

F , FI , BV ( 1 ) ,B 

INTEGER 

J 

B  =  ( BV ( J ) *  *  2  -  F**2 )/( F**2  -  FI  *  *2 ) 


RETURN 

END 


REAL  FUNCTION  SVAN ( S , T , PO , SIGMA ) 

Q  ********************************************************************** 

C  SPECIFIC  VOLUME  ANOMALY  (STERIC  ANOMALY)  BASED  ON  1980  EQUATION 
C  OF  STATE  FOR  SEAWATER  AND  1978  PRACTICAL  SALINITY  SCALE. 

C 

C  REFERENCES  : 

C  MILLERO,  ET  AL  (1980)  DEEP-SEA  RES 27A, 255-264 

C  MILLERO  AND  POISSON  1981 , DEEP-SEA  RES.,28A  PP  625-629. 

C 

C  BOTH  ABOVE  REFERENCES  ARE  ALSO  FOUND  IN  UNESCO  REPORT  38  (1981) 

C  MODIFIED  RCM 
C  UNITS: 

C  PRESSURE  PO  DECIBARS 

C  TEMPERATURE  T  DEG  CELSIUS  (IPTS-68) 

C  SALINITY  S  ( IPSS-78 ) 

C  SPEC.  VOL.  ANA.  SVAN  M**3/KG  *1.0E-8 

C  DENSITY  ANA.  SIGMA  KG/M**3 

Q  ********************************************************************** 

C 


n  n  o  non 


C  CHECK  VALUE:  SVAN-981 . 30.’ '  E-8  M**3/KG.  FOR  S  -  40  (IPSS-78)  ,  * 

C  T  -  40  DEG  C,  P0-  10000  DECIBARS.  * 

C  * 

C  CHECK  VALUE:  SIGMA  -  59.82037  KG/M**3  FOR  S  -  40  (IPSS-78)  ,  * 

C  T  -  40  DEG  C,  P0*  10000  DECIBARS.  * 

C  * 

£  ********************************************************************** 

REAL  P,T,S, SIG,SR,R1,R2,R3,R4 
REAL  A,B,C,D,E,A1,B1,AW,BW,K,K0,KW,K35 

********************* 

*  EQUIVALENCE  STMTS  * 
********************* 

EQUIVALENCE  ( E , D , Bl ) , ( BW , B , R3 ) , ( C , Al , R2 ) 

EQUIVALENCE  ( AW , A , R1 ) , ( KW , K0 , K ) 

******************** 

*  DATA  * 

******************** 

DATA  R3500,R4/1 028. 1063,4. 8314 E- 4/ 

DATA  DR350/28 .106331/ 

Q********************************************************************* 

C  R4  IS  REFERED  TO  AS  C  IN  MILLERO  AND  POISSON  1981  * 

C  CONVERT  PRESSURE  TO  BARS  AND  TAKE  SQUARE  ROOT  SALINITY.  * 

£********************************************************************* 

P=P0/10 . 

SR  *  SQRT ( ABS ( S ) ) 

c  ******************************************************************** 

C  PURE  WATER  DENSITY  AT  ATMOSPHERIC  PRESSURE  * 

C  BIGG  P . H . , (  1 96 7  )  BR.  J.  APPLIED  PHYSICS  8  PP  521-537.  * 

Q  ******************************************************************** 

Rl  -  (  (  ( (6.536332E-9*T-1.120083E-6)*T+1.001685E-4)*T 
1  -9. 095290 E- 3)* T+6. 793952 E- 2)* T- 28. 263737 

Q  ******************************************************************** 

C  SEAWATER  DENSITY  ATM  PRESS.  * 

C  COEFFICIENTS  INVOLVING  SALINITY  * 

C  R2  -  A  IN  NOTATION  OF  MILLERO  AND  POISSON  1981  * 

Q  ★*★***★★**★***★★★**★*★★★★**★★★*★★*********★*★★****★★*★*★*★★★*******★ 

R2  =  (  (  (  5.3875E-9*T-8.2467E-7)*T+7.6438E-5)*T-4.0899E-3)*T 
1  +8 . 24493E-1 


C  R3  -  B  IN  NOTATION  OF  MILLERO  AND  POISSON  1981  * 

R3  -  (-1.6546E-6*T+1.0227E-4)*T-5.72466E-3 

C  INTERNATIONAL  ONE-ATMOSPHERE  EQUATION  OF  STATE  OF  SEAWATER  * 

SIG  -  (R4*S  +  R3*SR  +  R2)*S  +  Rl 

C  SPECIFIC  VOLUME  AT  ATMOSPHERIC  PRESSURE  * 


V350P  *  1 . 0/R3500 

SVA  -  -SIG*V350P/(R3500+SIG) 

SIGMA  »  SIG+DR350 

C  ******************************************************************* 

C  SCALE  SPECIFIC  VOL.  ANAMOLY  TO  NORMALLY  REPORTED  UNITS 
^  ******************************************************************* 

SVAN=SVA* 1 . OE+8 
IF(P.EQ.O.O)  RETURN 

Q  ******************************************************************** 
C  ********  NEW  HIGH  PRESSURE  EQUATION  OF  STATE  FOR  SEAWATER  ********* 
c  ******************************************************************** 
C  MILLERO,  ET  AL  ,  1980  DSR  27A,  PP  255-264  * 

C  CONSTANT  NOTATION  FOLLOWS  ARTICLE  * 

Q*  *******************************************************************  * 

C  * 

C  COMPUTE  COMPRESSION  TERMS  * 

Q  ******************************************************************** 

E  -  (9.1697E-10*T+2.0816E-8)*T-9.9348E-7 
BW  -  (5.2787E-8*T-6.12293E-6)*T+3.47718E-5 
B  *  BW  +  E*S 


D  -  1 . 91075E-4 

C  -  (-1.6078E-6*T-1.098lE-5)*T+2.2838E-3 
AW  =  ( (-5.77905E-7*T+1.16092E-4)*T+1.43713E-3)*T 
1  -0.1194975 

A  -  (D*SR  +  C)*S  +  AW 

B1  *  (-5.3009E-4*T+1.6483E-2)*T+7.944E-2 
A1  -  ( (-6.1670E-5*T+1.09987E-2)*T-0.603459)*T+54.6746 
KW  -  ( ( (-5.155288E-5*T+1.360477E-2)*T-2.327105)*T 
1  +148. 4206)* T- 1930. 06 

K0  -  ( B1*SR  +  Al ) * S  +  KW 


C  EVALUATE  PRESSURE  POLYNOMIAL  * 
C  * 
C  K  EQUALS  THE  SECANT  BULK  MODULUS  OF  SEAWATER  * 
C  DK  -  K(S,T,P)— K( 3  5 , 0  ,  P  }  * 
C  K35  -  K ( 3 5 , 0 , P )  * 


£  ******************************************************************** 
DK  -  ( B*P  +  A ) *P  +  K0 

K35  -  ( 5.03217E-5*P+3.359406)*P+21582.27 

GAM-P/K35 

PK  -  1.0  -  GAM 

SVA  -  SVA* PK  +  ( V3 50P  +  SVA ) *P*DK/( K35*(K35  +  DK) ) 

C  ******************************************************************** 

C  SCALE  SPECIFIC  VOL.  ANAMOLY  TO  NORMALLY  REPORTED  UNITS  * 

Q  ******************************************************************** 

SVAN«SVA*1 . OE+8 
V350P  -  V350P*PK 


C  ********************************************************************* 

C  COMPUTE  DENSITY  ANAMOLY  WITH  RESPECT  TO  1000.0  KG/M**3  * 
C  1)  DR3 50  :  DENSITY  ANAMOLY  AT  35  (IPSS-78),  0  DEG.  C  AND  0  DECIBARS  * 
C  2)  DR35P:  DENSITY  ANAMOLY  35  (IPSS-78),  0  DEG.  C  ,  PRES.  VARIATION* 


oonnoonooonnnnnonon 


C  3)  DVAN  :  DENSITY  ANAMOLY  VACATIONS  INVOLVING  SPECFIC  VOL.  ANAMOLY* 

Q  ********************************************************************* 

C  * 

C  CHECK  VALUE:  SIGMA  -  59.82037  KG/M**3  FOR  S  -  40  (IPSS-78),  * 

C  T  -  40  DEG  C,  P0-  10000  DECIBARS.  * 

Q  ********************************************************************* 

DR35P  -  GAM/V350P 

DVAN  -  SVA/( V350P* ( V350P+SVA) ) 

SIGMA  -  DR350+DR35P-DVAN 

RETURN 

END 


REAL  FUNCTION  THETA ( S , TO , P0 , PR ) 

******************************************************************** 
TO  COMPUTE  LOCAL  POTENTIAL  TEMPERATURE  AT  PR  * 

USING  BRYDEN  1973  POLYNOMIAL  FOR  ADIABATIC  LAPSE  RATE  * 


AND  RUNGE-KUTTA  4-TH 

ORDER 

INTEGRATION  ALGORITHM. 

* 

REFERENCES: 

* 

BRYDEN, H. , 197 3 , DEEP-SEA 

RES. ,20,401-408 

* 

FOFONOFF , N . , 1977 , DEEP-SEA  RES. ,24,489-491 

* 

* 

UNITS: 

* 

PRESSURE 

P0 

DECIBARS 

* 

TEMPERATURE 

TO 

DEG  CELSIUS  (IPTS-68) 

* 

SALINITY 

S 

( IPSS-78  ) 

* 

REFERENCE  PRS 

PR 

DECIBARS 

* 

POTENTIAL  TMP . 

THETA 

DEG  CELSIUS 

* 

CHECKVALUE:  THETA-  36 

.89073 

C , S-40  (IPSS-78) ,T0-40  DEG  C, 

* 

P0-10000  DECIBARS, PR- 

0  DECIBARS 

* 

********************* 

****** 

*********************************** 

****** 

******************************************************************** 

C  SET-UP  INTERMEDIATE  TEMPERATURE  AND  PRESSURE  VARIABLES 

Q  ******************************************************************** 

P  -  P0 
T  -  TO 


H  -  PR  -  P 

XK  -  H*ATG (  S  ,  T ,  P  ) 

T  -  T  +  0 . 5*XK 
Q  -  XK 

P  -  P  +  0 . 5*H 
XK  -  H*ATG{ S , T, P ) 

T  -  T  +  0.29289322M XK-Q) 

Q  -  0.58578644*XK  +  0.121320344*0 
XK  -  H*ATG(S,T,P) 

T  -  T  +  1 .707106781*(XK-Q) 

Q  -  3 . 414213562*XK  -  4.121320344*0 
P  -  P  +  0 . 5*H 
XK  -  H*ATG (  S  ,  T ,  P  ) 

THETA  -  T  +  ( XK-2 . 0*Q ) /6 . 0 

RETURN 

END 


REAL  FUNCTION  ATG(S,T,P) 


noononnnnooonnn 


ADIABATIC  TEMPERATURE  GRADIENT  DEG  C  PER  DECIBAR 


REFERENCES: 

BRYDEN , H . , 1973 , DEEP-SEA 


UNITS: 

PRESSURE  P 

TEMPERATURE  T 

SALINITY  S 

ADIABATIC  ATG 


RES. ,20,401-408 
DECIBARS 

DEG  CELSIUS  (IPTS-68) 
( IPSS-78 ) 

DEG.  C/DECIBAR 


* 

* 

* 

* 

* 

* 

* 

★ 

* 

* 


CHECKVALUE:  * 

ATG* 3 . 255976 E- 4  C/DBAR  FOR  S-40  (IPSS-78),  * 

T=4 0  DEG  C,P0«10000  DECIBARS  * 

**************************************************************** 


DS  -  S  -  35.0 


ATG  =  ( ( (-2.1687E-16*T+1.8676E-14)*T-4.6206E-13)*P 

1  +  ( (2.7759E-12*T-1.135lE-10)*DS+( ( -5 . 4481E-14*T 

2  +  8 . 7 3 3E-12 ) *T-6 . 7 7 9 5E-1 0 ) *T+1 . 87 4 IE-8  )  ) *P 

3  +  ( -4 . 2  39  3E-8  *T+1 . 89  32E-6 ) *DS 

4  +  ( (6.6228E-10*T-6.836E-8)*T+8.5258E-6)*T+3.5803E-5 


RETURN 

END 


nnnnonooonoonooononono 


PROGRAM  M0DEL1  CTL  LIST 


OPEN (  UN IT* 16 , FILE- ' MODELl . CTL ' , STATUS- ' OLD ' , 

1  DISP- ' KEEP ' /ACCESS- ' DIRECT' ,RECL-5) 

READ ( 1 6 ' 1 )  NX,DX,XMAX 
READ(16'2)  NZ,DZ,ZMAX 
READ( 16 ' 3 )  NT,DT,TMAX 

READ ( 1 6 ' 4 )  LAT , LON , LATl , LONl , AZIMUTH 
READ( 16 ' 5 )  T , I T_T 

WRITE ( 6 , 1000 )  NX,DX,XMAX,NZ , DZ , ZMAX , NT , DT , TMAX , 
1  LAT, LON, LATl, LONl, AZIMUTH, T, IT  T 


CLOSE (  UNIT-16) 
STOP 


1000  FORMAT( 

1 
2 

3 

4 

5 

6 

7 


NX , DX , XMAX  ',  1 5 , 2G2  0 . 5  / 
NZ , DZ , ZMAX  ',  I5,2G20.5  / 
NT, DT, TMAX  ',  I5,2G20.5  / 
LAT, LON  ',  5X , 2G20 . 5/ 

LATl, LONl  ',  5X, 2G20 . 5/ 

AZIMUTH  ',  5X ,  G20.5/ 

T  ',  5X,  G20.5/ 

T  iteration  ',  15//) 


END 


ooooonnnnnnnnnonnonnnnnrjnonnn 


PROGRAM: 

PURPOSE: 


AUTHOR 

INPUT 


* 

LEVASC  * 

* 

THIS  PROGRAM  READS  A  DIRECT  ACCESS  FILE  CREATED  BY  LEVRD  * 
AND  WRITES  THE  DATA  IN  ASCII  FORMAT.  THE  OUTPUT  GROUP  * 
CONSISTS  OF  30  DEPTH  LEVELS  WITH  DEPENDENT  VARIABLES  OF  * 
NO.  OF  TEMP  OBSERVATIONS,  MEAN  TEMP,  STANDARD  DEVIATION  OF* 
TEMP,  NO.  OF  SAL  OBSERVATIONS,  MEAN  SAL,  AND  STANDARD  * 

DEVIATION  OF  SAL.  THE  MEAN  SEASON  DAY,  LAT,  AND  LONG  ARE  * 

ALSO  OUTPUT.  * 

* 

S.A.  Briggs  (NOARL,  Code  331)  * 

★ 

★ 

_ _ _ _ _ _ _ _ * 


Unit  Filename  .Type  Contents  * 

_ * 

10  LEVITUS.DAT  «  direct  »  LEVITUS  data  * 

_ * 


* 


OUTPUT 


* 


Unit 

Filename 

Type 

Contents 

* 

11 

LEVITUS .ASC 

«  Ascii  » 

LEVITUS  data 

★ 

DIMENSION  D( 180 ) 

WRITE( 6, *) 'CLIMATOLOGICAL  ATLAS  OF  THE  WORLD  OCEAN  ' 
WRITE ( 6 , * ) ' ( NOAA  PROFESSIONAL  PAPER  NO.  13,  DEC  1982)' 
WRITE ( 6 , * ) 

WRITE ( 6 , * )  '>>>  WRITING  THIS  FILE  INTO  ASCII  FORMAT' 

C  OPEN  INPUT  &  OUTPUT  FILES 

OPEN ( UNIT-1 0 , FI LE- ' DRBO : [ CLIMATE ] LEVITUS . DAT ' , 

&  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' , STATUS-'OLD' , 

&  ERR-1 ,RECL-180, READONLY) 

IOU  -  11 

OPEN ( UNI T-IOU, FI LE-' LEVITUS. ASC' , STATUS- ' NEW' ) 


DO  IREC  -  1,999999 

READ( 10 ' IREC, IOSTAT-I FLAG) D 

IF  ( I  FLAG  .EQ.  36 )  GO  TO  2  1  END  OF  FILE  CONDITION 

DO  I  -  1,30 
I  FACT- 1  *  6 

WRITE ( IOU ,100, ERR- 3 ) ( D ( J ) , J-I FACT-5 , 1  FACT ) 

100  FORMAT  (6G13.3) 

END  DO 
END  DO 


C  PROGRAM  TERMINATION  POINTS 

1  WRITE( 6 , * ) ' ERROR  IN  OPENING  LEVITUS  FILE' 

STOP 

2  WRITE ( 6 , * ) '  END  OF  PROGRAM' 

STOP 

3  WRITE( 6 , * ) ' ERROR  IN  WRITING  OUTPUT  FILE,  UNIT  ' , IOU 


STOP 

END 


nnnnnnnonnnonon 


★a************************************************************************** 

PROGRAM:  ASCLEV  * 

* 

PURPOSE:  THIS  PROGRAM  READS  AN  ASCII  FORMAT  CREATED  BY  LEVASC  AND  * 

WRITES  THE  DATA  INTO  A  DIRECT  ACCESS  FILE.  THE  OUTPUT  GROUP  * 

CONSISTS  OF  30  DEPTH  LEVELS  WITH  DEPENDENT  VARIABLES  OF  * 

NO.  OF  TEMP  OBSERVATIONS,  MEAN  TEMP,  STANDARD  DEVIATION  OF  * 

TEMP,  NO.  OF  SAL  OBSERVATIONS,  MEAN  SAL,  AND  STANDARD  DEVIATION* 
OF  SAL.  THE  MEAN  SEASON  DAY,  LAT,  AND  LONG  ARE  ALSO  OUTPUT.  * 

* 


AUTHOR: 


S.A.  BRIGGS  (NOARL,  Code  331) 


DIMENSION  D( 180 ) 


WRITE (6, 100) 'CLIMATOLOGICAL  ATLAS  OF  THE  WORLD  OCEAN  ' 

WRITE ( 6 , 100 ) ' ( NOAA  PROFESSIONAL  PAPER  NO.  13,  DEC  1982)' 

WRITE (6,100) 

WRITE( 6,100)  '>>>  WRITING  THIS  FILE  INTO  DIRECT  ACCESS  FORMAT' 
100  FORMAT  (A) 


C  INPUT  FILE  * 

IOU  -  11 

OPEN (  UNI T=IOU,  FILE-  'MODEL$  :  LEVITUS  .  ASC  '  ,  STATUS*  '  OLD '  , 
&  ERR=1, READONLY) 


C  OUTPUT  FILE  * 

OPEN( UNIT* 10 , FILE*' levitus.dat' , 

&  ACCESS- 'DIRECT' , FORM- ' UNFORMATTED ' , STATUS- ' NEW ' , 

&  ERR* 2 ,RECL=180) 


DO  IREC  -  1,999999 
DO  I  -  1,30 
IFACT-I*6 

READ ( IOU, 2 00, END- 5, ERR- 3 ) (D( J ) , J- 1  FACT-5 , 1  FACT) 

200  FORMAT  (6G13.3) 

END  DO 

WRITE ( 10, REC-IREC,ERR-4 )D 
END  DO 

C************** 

C  ERROR  MSGS  * 

£****★★*★*★**★★ 

1  WRITE(6,100) '  ERROR  IN  OPENING  INPUT  LEVITUS  ASCII  FILE' 
STOP 

2  WRITE( 6,100)'  ERROR  IN  OPENING  OUTPUT  LEVITUS  BINARY  FILE' 
STOP 


3 


WRITE(6,*)'  ERROR  IN  READING  INTPUT  FILE,  UNIT 
STOP 


IOU 


4  WRITE{6,100) '  ERROR  IN  WRITING  OUTPUT  LEVITMS  FILE' 

STOP 


C  NORMAL  TERMINATION  * 

5  WRITE* 6 , 100 ) '  END  OF  PROGRAM' 
STOP 


END 


nnn  nonnooooonoooooonnooonoo 


PROGRAM  M0DEL1_UVW_RLAD 

★  ★★★★★★★★♦★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★A** 

PROGRAM  MODELl_UVW_READ 

PURPOSE  READ  U,V,W  FIELDS 

AUTHOR  K.D.  Saunders  (NORDA,  Code  331) 

INPUT 


Unit 

Filename 

Type 

Contents 

5 

SYS$INPUT 

KEYBOARD 

Control  Information 

14 

MODELl .UV 

«  direct  » 

UVW  data  to  plot 

13 

MODELl .AUX 

«  ascii  » 

Descriptor  for  MODELl . DAT 

★ 

★ 

★ 

* 

* 

★ 

* 

★ 


★ 

* 

it 


OUTPUT 


Unit  Filename  Type  Contents 


SYSSOUTPUT  «cntl  window*  Program/control  information 


IMPLICIT  NONE 

INTEGER*  4  MAX 

PARAMETER  (MAX-500) 

CHARACTER*80  LINE,CBUFF( 20 ) 

INTEGER*  4  I,NT,IDX,IDZ 

INTEGER* 4  NXX , NZZ , IX , I Z , NVARS 

REAL* 4 

1  DT , DXX , DZZ , XMAX , 

2  TD ( MAX , MAX )  ,  SD  ( MAX , MAX ) , 

3  U ( MAX , MAX )  ,  V  ( MAX , MAX ) , W ( MAX , MAX ) 


EQUIVALENCE  (SD(1,1),U(1,1)),(TD(1,1),V(1,1)) 


GET  INPUT  DATA  GENERATED  BY  MODELl  * 

A*********************************************************************** 


1  FORMAT ( A ) 

OPEN  ( FILE-' MODELl . AUX ' , UNIT-1 3 , STATUS- ' OLD ' ,DISP-'KEEP' ) 


READ (13,1)  LINE 

READ (13,1)  LINE 

READ ( 1 3  f 1 )  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ(CBUFF( 2 ) ,*)  NT 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NXX 


READ (13,1)  LINE 

CALL  PARSE( LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NZZ 

READ (13,1)  LINE 

CALL  PARSEC  LINE , C3UFF , NVARS ) 

READ (CBUFF{2) ,*)  DT 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  DXX 

XMAX  -  DXXMNXX-1) 

READ (13,1)  LINE 

CALL  PARSE( LINE, CBUFF, NVARS ) 

READ ( CBUFF ( 2 ) , * )  DZZ 


TYPE  * ,  '  NT , NX , NZ , DT , DX , DZ  ' 

TYPE  *,  NT, NXX, NZZ 
TYPE  *,  DT, DXX, DZZ 

TYPE  *  ,  '  ENTER  DIX,DIZ  ' 

ACCEPT  *,  I DX , IDZ 

TYPE  *  ,  '  ******  PLEASE  WAIT  -  READING  IN  DATA  ************** 


OPEN  ( FILE-' MODEL 1 . UV' , UNI T-l 4 , STATUS- ' OLD ' ,DISP«'KEEP' , 
1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' ,RECL»3*NZZ) 


DO  IX-  1 , NXX , IDX 

READ (14' IX) (U( I, IX) ,V( I ,IX) ,W( I , IX) ,1-1, NZZ) 

DO  IZ  -  1, NZZ, IDZ 

WRITE (6, 100)  IX, IZ,U( IZ,IX) ,V(IZ,IX) ,W(IZ,IX) 
100  FORMAT (  215, 3G20 . 5 ) 

END  DO 

END  DO 


STOP 

END 


nononoonnoononoonnnnnnnn 


PROGRAM  M0DEL1_L00K 

* 

PROGRAM  M0DELl_L00K  * 

* 

PURPOSE  LISTS  MODELl  DISPLACEMENT  FIELDS  * 

* 

AUTHOR  K.D.  Saunders  (NOARL,  Code  331)  * 


INPUT 


Unit 

Filename 

Type 

Contents 

★ 

_  _  _  * 

5 

aiS$ INPUT 

KEYBOARD 

Control  Information 

* 

12 

MODELl . DAT 

«  direct  » 

Data  to  plot 

* 

13 

MODELl .AUX 

•«  ascii  » 

Descriptor  for  MODELl . DAT 

* 

it 

OUTPUT 

* 

★ 

_ It 

Unit 

Filename 

Type 

Contents 

* 

_  _  * 

6 

SYS$OUTPUT 

«cntl  window* 

Program/control  information 

* 

_ * 

IMPLICIT  NONE 

INTEGER*  4 
PARAMETER 

CHARACTER*  2 
CHARACTER*  8  0 


REAL*  4 
REAL* 4 
REAL*  4 

1 

2 


INTEGER*  4 
INTEGER*  4 

1 


DATA  J/17.0/ 

DATA  K/l 6/ 

C  GET  INPUT  DATA  GENERATED  BY  MODELl  * 


MAX 

( MAX=  500  ) 

PLOT_TYPE 
LINE , CBUFF ( 20  ) 


X, Y, XMAX , YMAX 

J ,  K ,  R ,  Z 

T ( MAX ) ,  S ( MAX ) ,  BV ( MAX ) , 

ZD ( MAX , MAX )  , DT , DXX , DZ  Z , WM , WP , WT , HM , HP , HT , 

T  AV ( MAX ) , S  AV ( MAX ) , TD ( MAX , MAX ) , SD ( MAX , MAX ) 


N,I 

NXX , NZZ , NT , IX , I Z , NVARS , IZMIN, IZMAX, IZDELTA, 
IXMIN , I XMAX , IXDELTA 


1 


FORMAT ( A ) 

OPEN  (FILE-' MODELl . AUX ' , UNIT-1  3 , STATUS- ' OLD '  ,DISP-'KEEP' ) 


READ (13,1)  LINE 

READ (13,1)  LINE 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS ) 

READ (C8UFF(2),*)  NT 

READ (13,1)  LINE 

CALL  PARSE(LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NXX 


READ (13,1)  LINE 

CALL  PARSE( LINE, CBUFF, NVARS ) 

READ (CBUFF(2),*)  NZZ 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS ) 

READ ( CBUFF ( 2 ) , * )  DT 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS ) 

READ (CBUFF(2) ,*)  DXX 

READ (13,1)  LINE 

CALL  PARSE(LINE, CBUFF, NVARS) 

READ (CBUFF(2) ,*)  DZZ 


TYPE  *,  '  NT , NX , NZ , DT , DX , DZ  ' 

TYPE  *,  NT, NXX, NZZ 
TYPE  *,  DT , DXX , DZZ 


OPEN  ( FILc= ' MODELl .DAT'  , UNIT-1  2 , STATUS* ' 01 D '  ,DISP-'KEEP' 
ACCESS- ' DIRECT'  , FORM- ' UNFORMATTED '  ,RECL-4*NZZ  ) 


DO  IX  =  1 , NXX 

READ (12 'IX) (ZD (I, IX) , T( I ) , S ( I ) , BV ( I ) , 1-1 , NZZ ) 
DO  IZ  -  1 , NZ Z 

TD( IZ, IX)  -  T( IZ ) 

SD( IZ , IX'  -  S( IZ ) 

T_AV ( I Z )  -  T_AV(IZ)  +  T ( I Z ) 

S_AV ( I Z )  -  S_AV ( I Z )  +  S(IZ) 

END  DO 

END  DO 

DO  IZ  -  1 , NZ Z 

T_AV ( I Z )  -  T_AV ( I Z ) /NXX 
S_AV ( I Z )  -  S_AV ( I Z ) /NXX 

END  DO 

DO  IX  -  1 , NXX 

DO  IZ  -  1,  NZZ 

TD ( I Z , I X )  -  TD ( I Z , I X )  -  T_AV ( I Z ) 

SD ( I Z , IX )  -  SD ( I Z , I X )  -  S_AV ( I Z ) 

END  DO 

END  DO 


TYPE  *  ,'  ENTER  PLOT  TYPE  :  ZD,TD,SD  ' 
ACCEPT  1,  PLOT  TYPE 


T 


1 

1 


I F  (  PLOT_TYPE  .EQ.  'TD'  .OR.  PLOT_Ti'PE  .EQ.  'SD'  )  THEN 
DO  IX  *  1 , NXX 

DO  IZ  =  1 ,  NZ Z 

I F (  PLOT  TYPE  .EQ.  'TD'  ) 

ZD( IZ , ixl  -  TD( IZ , IX) 

I F  (  PLOT_TYPE  .EQ.  'SD') 
ZD ( I Z , IX )  -  SD{ IL , IX) 

END  DO 

END  DO 


END  IF 


C  GET  INPUT  DATA  FOR  SCREEN  CONTROL 


TYPE  *,  '  ENTER  IZMIN, IZMAX, I Z DELTA' 

ACCEPT  *,  IZMIN, IZMAX, IZDELTA 


TYPE  *,  '  ENTER  IXMIN, IXMAX , IXDELTA' 

ACCEPT  *,  IXMIN, IXMAX, IXDELTA 


DO  IZ  =  IZMIN, IZMAX, IZDELTA 
DO  IX  =  IXMIN, IXMAX, IXDELTA 

TYPE  *.  '  IZ,IX,  VALUE' , IZ , IX, ZD( IZ , IX) 

END  DO 
END  DO 


STOP  '  END  MODELl_LOOK ' 
END 


oonnoooonnnonorinonononnn 


PROGRAM  M0DEL1_L00K 

★  *★★**★***★*★★★************★*★★★****★*★*★*★*★**★*★★*******★*★★★****★***★ 

* 

PROGRAM  M0DEL1_L00K  * 

X 

PURPOSE  LISTS  MODELl  DISPLACEMENT  FIELDS  * 

* 

AUTHOR  K.D.  Saunders  (NOARL,  Code  331)  * 

★ 

INPUT  * 


* 


Unit 

Filename 

Type 

Contents 

* 

5 

SYS$ INPUT 

KEYBOARD 

Control  Information 

* 

12 

MODELl . DAT 

«  direct  » 

Data  to  plot 

it 

13 

MODELl .AUX 

«  ascii  » 

Descriptor  for  MODELl . DAT 

it 

_ * 

OUTPUT 

* 

★ 

_ _ it 

Unit 

Filename 

Type 

Contents 

it 

_ * 

6 

SYS$OUTPUT 

«cntl  window* 

Program/control  information 

* 

_ * 

IMPLICIT  NONE 

INTEGER*  4 
PARAMETER 

CHARACTER* 2 
CHARACTER* 80 


REAL*  4 
REAL*  4 
REAL*  4 

1 

2 


INTEGER*  4 
INTEGER*  4 

1 


DATA  J/17.0/ 

DATA  K/16/ 

C  GET  INPUT  DATA  GENERATED  BY  MODELl  * 


MAX 

(MAX-500 ) 

PLOT_TYPE 

LINE,CBUFF(20) 


X ,  Y , XMAX , YMAX 

J  ,  K  ,  R ,  Z 

T ( MAX ) ,  S ( MAX ) ,  BV ( MAX ) , 

Z  D ( MAX , MAX ) , DT , DXX , DZZ , WM , WP ,  WT , HM , HP , HT , 

T  AV ( MAX ) , S  AV ( MAX )  ,  TD  ( MAX , MAX )  ,  SD  ( MAX , MAX ) 


N,I 

NXX , NZZ , NT , IX , I Z , NVARS , I ZMIN , IZMAX , I Z DELTA, 
IXMIN , I XMAX , IXDELTA 


1 


FORMAT ( A ) 

OPEN  (FILE-  'MODEM  .  AUX'  ,  UNIT-- 1  3  ,  STATUS- '  OLD '  ,DISP-'KEEP'  ) 


READ (13,1)  LINE 

READ (13,1)  LINE 

READ (13,1)  LINE 

CALL  PARSE( LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NT 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NV^RS ) 

READ ( CBUFF ( 2 ) , * )  NXX 


READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS ) 

READ ( CBUFF ( 2 ) , * )  NZZ 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF (  2  )  ,  *  )  DT 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  DXX 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ (CBUFF(2) ,*)  DZZ 


TYPE  *,  '  NT , NX , NZ , DT , DX , DZ  ' 

TYPE  *,  NT, NXX, NZZ 
TYPE  *,  DT, DXX, DZZ 


OPEN  ( FILE*' MODELl . DAT ' , UN IT* 12 , STATUS* 'OLD' ,DISP«'KEEP' 
ACCESS- 'DIRECT' , FORM- ' UNFORMATTED ' ,RECL-4*NZZ) 


DO  IX  -  1 , NXX 

READ( 12' IX) ( ZD ( I , IX) ,T( I ) ,S( I ) 


DO  IZ  « 

1  ,NZZ 

TD( IZ , IX) 

-  T( IZ  ) 

SD ( IZ , IX ) 

-  S  (  I Z  ) 

T  AV ( IZ ) 

-  T  AV(IZ)  + 

S  AV(IZ) 

■  S  AV(IZ)  + 

END  DO 

END  DO 

DO  IZ  - 

1  ,NZZ 

T  AV ( IZ) 

-  T  AV ( IZ )/NXX 

S_AV ( IZ ) 

-  S  AV ( I Z ) /NXX 

END  DO 

DO  IX  - 

1  ,NXX 

DO  IZ  - 

1,  NZZ 

TD ( IZ , IX) 

-  TD ( IZ, IX) 

SD( IZ , IX ) 

-  SD ( I Z , IX ) 

END  DO 

END  DO 

TYPE  *  , 

'  ENTER 

PLOT  TYPE 

:  ZD , TD , SD  ' 

ACCEPT  1 

,  PLOT  TYPE 

,  BV (I ) ,1-1, NZZ ) 


T (  IZ  ) 
S(IZ) 


-  T_AV ( I Z ) 

-  S  AV(IZ) 


I F (  PLOT_TYPE  .EQ.  'TD'  .OR.  PLOT_TYPE  .EQ.  'SD'  )  THEN 
DO  IX  -  1 , NXX 

DO  12  -  1 , NZZ 

I F (  PLOT  TYPE  .EQ.  'TD') 

1  ZD(IZ,IXT  -  TD( IZ , IX) 

I F (  PLOT_TYPE  .EQ.  'SD') 

1  ZD ( I Z , IX)  -  SD( IZ , IX) 

END  DO 

END  DO 

END  IF 

C  GET  INPUT  DATA  FOR  SCREEN  CONTROL 

C*  *  *  *  *****  *  *  *  *  ********  ******  *  *********  *********  *  *  **************  * 

TYPE  *,  '  ENTER  I ZMIN , I ZMAX , I Z DELTA ' 

ACCEPT  * ,  IZMIN, IZMAX, IZDELTA 


TYPE  *,  '  ENTER  I XMIN , IXMAX , IXDELTA ' 

ACCEPT  *,  IXMIN, IXMAX, IXDELTA 

DO  IZ  =  IZMIN, IZMAX, IZDELTA 
DO  IX  -  IXMIN, IXMAX, IXDELTA 

TYPE  *,  '  IZ,IX,  VALUE' , I Z , IX , ZD ( I Z , IX ) 

END  DO 
END  DO 


STOP  '  END  MODELl_LOOK ' 
END 


oonooonnononoonnnnnnonnoo 


PROGRAM  M0DEL1  EIGLOOK 


* 

PROGRAM  M0DEL1  EIGLOOK  * 


PURPOSE  LIST  &  PLOT  EIGENMODES  AND  EIGENVALUES  * 

* 


AUTHOR  K . D . 

INPUT 

Saunders  (NOARL, 

Code  331) 

* 

* 

* 

_  _  * 

Unit 

Filename 

Type 

Contents 

* 

_ * 

5 

SYS$INPUT 

KEYBOARD 

Control  Information 

★ 

15 

MODELl. EIG 

«  direct  » 

Eigenvalues  and  modes 

* 

13 

MODELl .AUX 

«  ascii  » 

Descriptor  for  MODELl . DAT 

* 

_  _  * 

OUTPUT 

* 

* 

__  * 

Unit 

Filename 

Type 

Contents 

* 

_ * 

6 

SYSSOUTPUT 

«  cntl  window  » 

Program/control  information 

* 

NA 

POPFIL.DAT 

«  DISSPLA  METAFILE  »  Color  plots 

★ 

★ 


IMPLICIT  NONE 

INTEGER* 4  MAX 

PARAMETER  ( MAX- 1000) 

CHARACTER*  80  LINE , CBUFF ( 2 0 ) 

REAL*  4  K ( 2  0 ) , WMINT ( MAX )  ,  Z  ( MAX ) 

REAL*  4  DT , DXX , DZZ 

REAL *4  WMAX , WT , ZMAX 

INTEGER* 4  NXX , NZZ , NT , IX , I Z , NVARS , I  FREQ , NFREQ , NMODES , M , 

1  IT , LOC , NDX , NDF , NDM , KK 

Q* *********************************************************************** 

C  GET  INPUT  DATA  GENERATED  BY  MODELl  * 

Q************************************************************************ 

1  FORMAT ( A ) 


OPEN  ( FILE- 'MODELl .AUX' , UNIT-1 3 , STATUS- ' OLD ' ,DISP-'KEEP' ) 


READ(13,1)  LINE 

READ( 13,1)  LINE 

READ(13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NT 

READ (13,1)  LINE 

CALL  PARSE( LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NXX 


READ( 13,1)  LINE 


CALL  PARSE ( LINE, CBUFF , UVARS ) 
READ(CBUFF( 2) ,*)  NZZ 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS ) 

READ ( CBUFF ( 2 ) , * )  DT 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  DXX 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  DZZ 


TYPE  *,  '  NT , NX ,NZ,DT,DX,DZ  ' 
TYPE  *,  NT , NXX , NZ Z 
TYPE  *,  DT, DXX, DZZ 


WRITE ( 6 , * )  '  ENTER  ITERATION  NUMBER  ' 

READ ( 5 , * )  IT 


OPEN  ( FILE- '  MODEL  1  .  EIG'  ,  UNI  T«  1 5  ,  STATUS- '  OLD '  ,DISP-'KEEP'  , 
1  ACCESS- 'DIRECT' , FORM- ' UNFORMATTED ' ,RECL«NZZ+1 ) 

NMODES  -  6 
NFREQ  -  8 

WRITE ( * , * )  '  ENTER  NDX , NDF , NDM  ' 

READ ( * , * )  NDX, NDF, NDM 
DO  IZ  -  1 , NZ Z 

Z(IZ)  -  (  I  Z-l  )  *DZZ 

END  DO 

ZMAX  -  Z(NZZ) 


c  ********************** 

C  DISSPLA  SUBPROGRAMS  * 

Q  ********************** 

CALL  COMPRS 

DO  IX  -  1, NXX, NDX 

DO  I  FREQ  -  1, NFREQ, NDF 

CALL  SETCLR( %REF( 'GREEN' ) ) 

CALL  PAGE (8. 5, 11.0) 

CALL  AREA2D<  5. 0,6.0) 

CALL  FASHON 
CALL  HEIGHT( . 20 ) 

CALL  HEADIN( %REF( 'Vertical  Eigenmodes$ ' ) , 100 , 1 . 5 , 1 ) 

CALL  XNAME (  IREF (  ' W$ ' ) , 1 00 ) 

CALL  YNAME( IREF( 'DEPTH$  '),100) 

CALL  SETCLR( IREF( 'MAGENTA' ) ) 

CALL  GRAF (-1.2 5, IREF ( 'SCALE' ) , 1 . 2 5 , ZMAX , IREF ( 'SCALE' ) ,0) 
CALL  HEIGHT (0.15) 

CALL  MESSAG( IREF( ' IFREQ  -  $  '  )  ,  100 , 0 . 5 , -0 . 5 ) 

CALL  INTNO( IFREQ, IREF( 'ABUT' ) ,IREF( 'ABUT' ) ) 

CALL  MESSAG( IREF( ' IX  -  $  '  )  ,  100 , 0 . 5 , -0 . 8 ) 

CALL  INTNO( IX,IREF( 'ABUT' ) ,IREF( 'ABUT' ) ) 


DO  M  -  1 , NMOPFS , NDM 


LOC  -  M  +  ( IFREQ-1 ) * ( NMODES )  +  ( IX-1 )*( NMODES )*( NFREQ ) 

READ (15 'LOC)  K  (  M )  , ( WMINT ( KK ) , KK*1 , NZZ ) 

WRITE( 20,101)  IX , I  FREQ ,  M ,  K  (  M ) 

WMAX  »  1.0E-12 
DO  IZ  -  1 , NZZ 

I F (  ABS(WMINT( IZ) ) .GT.WMAX)  WMAX-ABS ( WMINT ( I Z ) ) 

WRITE ( 20, *)IZ,WMINT( IZ) 

END  DO 

WT  -  9.0/(9.0+(M-1)**2) 

WRITE ( * , * )  ' WMAX,WT  -  ',WMAX,WT 
DO  IZ  -  1 , NZZ 

WMINT(IZ)  -  WT*WMINT( IZ )/WMAX 

END  DO 

CALL  SETCLR( %REF( 'YELLOW' ) ) 

CALL  CURVE (  WMINT , Z , NZZ , 0 ) 


END  DO 

CALL  ENDPL(O) 

END  DO 
END  DO 

CALL  DONEPL 

101  FORMAT (  //  '  IX , I  FREQ , MODE  ',  315/'  K ( M )  -  ',G16.5// 

1  2X, ' IZ '  ,  '  W( IX , I  FREQ , M )  '//) 

100  FORMAT ( IX, I5,G16.5) 


STOP  '  END  MODELl_LOOK ' 
END 


noononoooonnnonnnoonnnnonoonoonnooooooononnnonnooo 


PROGRAM  M0DEL1  CONTOUR 


* 

PROGRAM  M0DEL1  CONTOUR  * 


PROGRAM 

PURPOSE 

AUTHOR 


COMPUTE  AND  PLOT  MODEL  FIELDS,  CONTOURING  VIA  DISPLA 
K . D .  Saunders  (NORDA,  Code  331) 


HISTORY 


10/28/88 


10/31/88 


11/5/88 


Program  written  based  on  FRACTAL  code 

Only  the  displacement  field  is  plotted 
at  present.  Later  modifications  will 
allow  plotting  temperature,  salinity 
and  their  deviation  fields. 

Modified  to  used  direct  writes  to  pixel 
locations  on  screen  (to  avoid  full 
memory  crashes . ) 

GPX  PROGRAM  ( PLOT_MODEL_FIELDS )  was 
modified  to  interpolate  the  data  and 
produce  contours  using  the  DISSPLA 
plotting  package. 


INPUT 

Unit  Filename 


Type 


Contents 


SYS$INPUT 
MODELl.DAT 
MODEL1 .AUX 


KEYBOARD 
«  direct  » 
«  ascii  » 


Control  Information 
Data  to  plot 

Descriptor  for  MODELl.DAT 


OUTPUT 


Unit 

Filename 

Type 

Contents 

* 

—  * 

6 

SYS$OUTPUT 

«cntl 

window* 

Program/control  information 

* 

NA 

SYS$WORKSTATION 

•  plot 

window* 

Color  plots 

* 

_ * 

Notes : 


This  program  is  designed  to  be  used  on  the  DEC  GKS 
Workstation  2000.  It  will  not  work  on  any  other  system 


IMPLICIT  NONE 

INTEGER*  4  MAX 

PARAMETER  (MAX-500) 


CHARACTER* 2  PLOT_TYPE 

CHARACTER *80  INFILE ,AUXFILE , DATFILE 

REAL* 4  X,Y,X_SIDE,Y_SIDE, 

1  X0 , Y0 , YMAX, 


1 

1 


XFACT , YFACT , ZP , ZM , XAR ( MAX*MAX ) ,  YAR( MAX*MAX) , 
ZAR( MAX*MAX ) , ZMAT( 200,200) 


CHARACTER* 80 

1 

2 

3 

4 


XTITLE  /'X$'/, 
YTITLE  /'Y$'/, 
ZTITLE , 

LINE, 

CBUFF ( 20 ) 


REAL *4  J,K,R, RED, GREEN, BLUE, DEG, SX, 

1  XLAST ,  XB  ,  XE ,  YLAST ,  YB  ,  YE ,  Z 

INTEGERM  I_INDEX(  10 , 10 , 10  )  ,NPTX,NPTY, 

1  VCM_SIZE,VD_ID,WD_ID,WD_ID2,N,I ,VCM_ID, 

2  I LAST, NITER, IXB , IXE , I YB , IYE , IM, L 


DATA  J/17.0/ 

DATA  K/16/ 

DATA  VCM  SIZE/130/ 


REAL* 4 

1 

2 

3 


T( MAX) ,  S ( MAX ) ,  ZZ(MAX),  BV(MAX), 

ZD (MAX, MAX) , DT , DXX , DZZ , WM , WP , WT , HM , HP , HT, 

T_AV ( MAX ) , S_AV ( MAX ) , TD ( MAX , MAX ) ,SD(MAX,MAX) , 
SVEL , XMAX , ZMAX, TZ , ZINCR , ZDMAX , ZDMIN, ZDZ , DX, DY 


INTEGER*  4  NXX , NZZ , NT , IX , IZ , NVARS , NCONT , IXX, I YY 


CHARACTER*60  TITLE1 , TITLE 2 

REAL *4  DUMMY( 100000) 

COMMON  DUMMY 

EQUIVALENCE  ( TD( 1,1) ,XAR( 1 ) ) , ( SD( 1 , 1 ) , YAR( 1 ) ) 

£*****★*★★**★****★*★★**★*★*★*★★*★★***★**★★★*★*★★***★**★*★*★*★★*★★*****★★* 
C  GET  INPUT  DATA  GENERATED  BY  MODELl  * 

Q*  **********************************************************************  * 


1  FORMAT(A) 

TYPE  *,  '  ENTER  INPUT  FILE  NAME  ' 

INFILE  -  '  ' 

ACCEPT  1,  INFILE 
DO  N  »  80, 1,-1 
L  -  N 

IF( INFILE(N:N)  .NE.  '  ')  GOTO  1000 

END  DO 

1000  CONTINUE 

AUXFILE  -  INFILE ( 1 : L )//' . AUX ’ 

DATFILE  -  INFILE(1:L)//' .DAT' 

TYPE  *, AUXFILE, DATFILE 

OPEN  (FILE-AUXFILE, UNIT-13, STATUS-'OLD' ,DISP-'KEEP' ) 


READ( 13,1)  LINE 
READ (13,1)  LINE 
READ (13,1)  LINE 
CALL  PARSE (LINE, CBUFF, NVARS) 


READ(CBUFF(2) ,*)  NT 


READ (13,1)  LINE 

CALL  PARSE ( LINE , CBUFF , NVARS ) 

READ{ CBUFF ( 2) ,* )  NXX 


READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2) ,*)  NZZ 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READtCBUFF(2) ,*)  DT 

READ( 13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ( CBUFF ( 2 ) , * )  DXX 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ(CBUFF(2) ,*)  DZZ 


TYPE  *,  '  NT , NX , NZ , DT , DX , DZ  ' 
TYPE  *,  NT, NXX, NZZ 
TYPE  *,  DT, DXX, DZZ 


XMAX  -  ( NXX— 1 ) *DXX 
ZMAX  -  ( NZZ— 1 ) *DZZ 

OPEN  (FILE-DATFILE, UNIT-12,  STATUS- 'OLD' ,DISP-'KEEP' , 
ACCESS-' DIRECT' , FORM- 'UNFORMATTED' ,RECL-4*NZZ) 


DO  IX  -  1 , NXX 

READ(12'IX) (ZD(I,IX) ,T(I) ,S(I) ,BV(I) ,1-1, NZZ) 

DO  IZ  -  1 , NZZ 

TD( IZ , IX)  -  T( IZ ) 

SD ( IZ , IX )  -  S(IZ) 

T_AV ( I Z )  -  T_AV ( I Z )  +  T( IZ ) 

S_AV ( I Z )  -  S_AV ( I Z )  +  S(IZ) 

END  DO 

END  DO 

DO  IZ  -  1 , NZZ 

T_AV ( I Z )  -  T_AV ( I Z ) /NXX 
S_AV ( I Z )  -  S_AV ( I Z ) /NXX 

END  DO 

TYPE  *  ,'  ENTER  PLOT  TYPE  ;  ZD,TD,SD,SV  ' 

ACCEPT  1,  PLOT_TYPE 

DO  IX  -  1 , NXX 

DO  IZ  -  1,  NZZ 

I F (  PLOT_TYPE  .NE.  'SV')  THEN 

TD( IZ , IX )  -  TD ( IZ , IX )  -  T_AV ( I Z ) 
SD( IZ , IX )  -  SD( IZ , IX)  -  S_AV ( I Z ) 

END  IF 

END  DO 

END  DO 

TITLEl  -  'Vertical  Displacement$ ' 

ZINCR  -  2.5 


I F (  PLOTJTYPE  .EQ.  'TD'  .OR.  PLOT_TYPE  .EQ.  'SD'  .OR. 

1  PLOTJTYPE  .EQ.  'SV'  )  THEN 

DO  IX  -  1 , NXX 

DO  IZ  -  1 ,  NZZ 

IF(  PLOT_TYPE  .EQ.  ' TD ' )  THEN 
TITLE1  -  'Temperature  Anomaly$' 

ZD( IZ , IX)  -  TD( IZ , IX) 

ZINCR  -  0.05 
END  IF 

IF(  PLOTJTYPE  .EQ.  'SD')  THEN 
TITLE1  -  'Salinity  Anomaly$' 

ZD(IZ,IX)  -  SD( IZ , IX) 

ZINCR  -  0.005 
END  IF 

I F (  PLOTJTYPE  .EQ.  'SV'  )  THEN 

TITLE1  -  'Sound  Velocity  AnomalyS' 

ZD( IZ , IX)  -  SVEL ( SD ( IZ , IX ) , TD ( IZ , IX ) , 
1  ( IZ-rl  )  *DZZ  ) 

IF( IX  .EQ.  1)  S  AV { I Z )  «  0 
S_AV ( I Z )  -  S_AVllZ)  +  ZD(IZ,IX) 

ZINCR  -  0.2 
END  IF 

END  DO 

END  DO 


IF (  PLOTJTYPE  .EQ.  'SV'  )  THEN 
DO  IZ  -  1 , NZZ 

S_AV ( I Z )  -  S_AV ( I Z ) /NXX 

END  DO 

DO  IX  -  1 , NXX 

DO  IZ  -  1 , NZZ 

ZD( IZ  fIX)  -  ZD ( I Z  , IX )  -  S_AV ( I Z ) 

END  DO 

END  DO 
END  IF 


END  IF 

ZD MAX  -  -1.0E10 
ZDMIN  -  1.0E10 

DO  IX  -  1 ,  NXX 

DO  IZ  -  1 , NZZ/2 

TZ  -  ZD( IZ , IX ) 

ZD( IZ , IX)  -  ZD(NZZ-IZ+1,IX) 

ZD(NZZ-IZ+1,IX)  -  TZ 

IF( ZDMAX  .LT.  TZ  )  ZDMAX  -  TZ 

IF( ZDMAX  .LT.  ZD(IZ,IX)  )  ZDMAX  -  ZD(IZ,IX) 

IF{ ZDMIN  .GT.  TZ  )  ZDMIN  -  TZ 

I F ( ZDMIN  .GT.  ZD( IZ . IX )  )  ZDMIN  -  ZD(IZfIX) 


END  DO 


END  DO 


o  o  o  o 


NCONT  -  ( ZDMAX-ZDMIN)/ZINCR 


TYPE  ZDMAX , ZDMIN , ZINCR , NCONT ' , ZDMAX, ZDMIN , ZINCR , NCONT 

IF  (NCONT  .GT.  50)  THEN 

ZINCR  -  (ZDMAX  -  ZDMIN)/49 
NCONT  -  25 

END  IF 


PLOTTING  SECTION 


NPTX  -  200 
NPTY  -  200 

X_SIDE  -  ( NXX-1 ) *DXX 
Y_SIDE  -  ( NZZ-1 ) *DZZ 

XMAX  •  X_S IDE 
YMAX  -  Y  SIDE 


DX  -  X_SIDE/NPTX 

DY  -  Y_SIDE/NPTY 

ZDMAX  -  -1.0E10 
ZDMIN  -  1.0E10 

DO  IXX  -  1 , NPTX 

X  -  ( IXX-1 ) *DX 
IX  -  X/DXX  +  1 
I F ( IX  .LT.  1)  IX  -  1 
IF( IX  .GT.  NXX )  IX  -  NXX 

WM  -  ABS ( ( IX-1 ) *DXX  -  X ) /DXX 
WP  -  ABS ( IX*DXX  -  X ) /DXX 
WT  -  WM+WP 
WM  -  1.0  -  WM/WT 
WP  -  1.0  -  WP/WT 


DO  IYY  -  1 ,NPTY 

Y  -  ( NPTY- ( I YY-1 ) ) *DY 

IZ  -  ( YMAX-Y)/DZZ  +  1 

IF( IZ  .LT.  1)  IZ  -  1 

IF( IZ  .GT.  NZZ)  IZ  -  NZZ 

HM  -  ABS ( ( IZ-1 ) *DZZ  -  (YMAX-Y) )/DZZ 

HP  -  ABS (  IZ*DZZ  -  (YMAX-Y) )/DZZ 

HT  -  HM  +  HP 

HM  -  1.0  -  HM/HT 

HP  -  1.0  -  HP/HT 


IM  -  IZ-1 

IF( IM.LE.l ) IM  -  1 


I F ( IX  .GT.  1)  THEN 


ZP  -  WP*ZD( IZ , IX)  +  WM*ZD( IZ , IX— 1 ) 

ZM  -  WP*ZD( IM, IX)  +  WM*ZD(IM,IX-1) 

ELSE 

ZP  -  ZD(IZ,IX) 

ZM  -  ZD{ IM, IX ) 

END  IF 

ZMAT( I XX , IYY )  -  ( HP*ZP  +  HM*ZM )/( HM+HP ) 

IF(  ZDMAX  .LT.  ZMAT( I XX , IYY ) )  ZDMAX  -  ZMAT( IXX, IYY) 
I F (  ZDMIN  .GT.  ZMAT ( I XX , I Y  Y ) )  ZDMIN  -  ZMAT( IXX, IYY ) 


endIdo  1  Y 

END  DO  1  X 


NCONT  -  ( ZDMAX-ZDMIN)/ZINCR 

TYPE  ZDMAX, ZDMIN, ZINCR, NCONT' , ZDMAX, ZDMIN, ZINCR, NCONT 

IF  (NCONT  .GT.  50)  THEN 

ZINCR  -  (ZDMAX  -  ZDMIN)/49 
NCONT  -  50 

END  IF 


CALL  COMPRS 

CALL  BCOMON( 100000) 

CALL  PAGE (  11.0,8.5) 

CALL  SCMPLX 

CALL  AREA2D ( 8 . 0 , 4 . 0 ) 

CALL  HEADIN( %REF( 'MODEL  OCEAN  SIMULATION ' ) , 1 00 , 1 . 2 , 2 ) 
CALL  HEADIN(%REF( TITLED ,100,1.0,2) 

CALL  MESSAG( %REF( 'Contour  interval  -  $ ' ) , 100 , 0 . 0 , -1 . 0 ) 
CALL  REALNO(ZINCR,3,%REF( 'ABUT' ) ,%REF( 'ABUT' )  ) 

CALL  YNAME( %REF( 'DEPTH:  m$'),100) 

CALL  XNAME( %REF( 'X-DI STANCE:  km  $'),100) 

CALL  GRAF ( 0. 0, 10. 0,XMAX,ZMAX, -1000. 0,0.0) 

CALL  FRAME 

CALL  CONMAK( ZMAT, 200, 200, ZINCR) 

CALL  CONMIN (1.0) 

CALL  CONDIG(l) 

CALL  CONLIN( 0 , %REF( 'MYCON' ) ,%REF( 'LABELS' ) ,2,10) 

CALL  CONLIN ( 1 , %REF ( 'MYCON' ) ,%REF( 'LABELS' ) ,1,8) 

CALL  CONTUR(2,%REF( 'LABELS' ) ,%REF( 'DRAW' ) ) 

CALL  ENDPL(l) 

CALL  DONEPL 

STOP 

END 

SUBROUTINE  MYCON ( RARAY , I ARAY ) 

REAL *4  RARAY ( 1 ) 

INTEGER*4  IARAY(l) 

I F (  RARAY ( 1 )  .LT.  0)  CALL  DOT 

IF(  RARAY ( 1 )  .LT.  0)  IARAY(l)  -  1 

I F (  RARAY ( 1 )  .GE.  0)  CALL  RESET( %REF ( ' DOT' ) ) 

I F (  RARAY ( 1 )  .GE.  0)  IARAY(l)  -  3 

RETURN 

END 


no  oonooonnn 


•REAL  FUNCTION  SVEL(S,T,P0) 
******************************* 

SOUND  SPEED  SEAWATER  CHEN  AND  MILLERO  1977 , JASA, 62 , 1129-1135 
UNITS: 


PRESSURE 

PO 

DECIBARS 

TEMPERATURE 

T 

DEG  CELSIUS  (IPTS 

SALINITY 

S 

(IPSS-78) 

SOUND  SPEED 

SVEL 

METERS/SECOND 

CHECKVALUE:  SVEL-1731 . 995  M/S,  S-40  ( IPSS-78 ) , T-40  DEG  C, P-10000  DBAR 

EQUIVALENCE  ( AO , BO , CO ) , ( Al , Bl , Cl ) , ( A2 , C2 ) , ( A3 , C3 ) 

SCALE  PRESSURE  TO  BARS 
P-P0/10. 

C************************** 

SR  -  SQRT( ABS ( S ) )  • 

C  S**2  TERM 

D  -  1.727E-3  -  7 . 9836E-6*P 
C  S**3/2  TERM 

Bl  -  7 . 3637E-5  +1.7945E-7*T 
BO  -  -1.922E-2  -4 . 42E-5*T 
B  -  BO  +  Bl*P 
C  S**l  TERM 

A3  -  (-3.389E-13*T+6.649E-12)*T+1.100E-10 
A2  -  ( (7.988E-12*T-1.6002E-10)*T+9.104lE-9)*T-3.9064E-7 
Al  -  ( ( (-2.0122E-10*T+1.0507E-8)*T-6.4885E-8)*T-1.2580E-5)*T 
X  +9  - 4742E-5 

AO  -  ( ( (-3.21E-8*T+2.006E-6)*T+7.164E-5)*T-1.262E-2)*T 
X  +1.389 

A  -  ( (A3*P+A2)*P+A1)*P+A0 
C  S**0  TERM 

C3  -  (-2.3643E-12*T+3.8504E-10)*T-9.7729E~9 

C2  -  ( ( (1.0405E-12*T-2.5335E-10)*T+2.5974E-8)*T-1.7107E-6)*T 
X  +3 . 1260E-5 

Cl  -  ( ( (-6.1185E-10*T+1.3621E-7)*T-8.1788E-6)*T+6.8982E-4)*T 
X  +0.153563 

CO  -  ( ( ( (3.1464E-9*T-1.47800E-6)*T+3.3420E-4)*T-5.80852E-2)*T 
X  +5.03711)*T+1402.388 
C  -  ( (C3*P+C2)*P+C1)*P+C0 
C  SOUND  SPEED  RETURN 

SVEL  -  C  +  (A+B*SR+D*S)*S 

RETURN 

END 


nnnnnnnnnnnnnnnnnnnnnnn 


PROGRAM  M0DEL1  EXPORT 


*  *  *  *  itjt  ***************************************************************** 

PROGRAM  MODELl_EXPORT 

PURPOSE  COMPUTE  AND  REFORMAT  MODEL  FIELD  DATA  FOR  EXPORTING 

TO  PC 

AUTHOR  K.D.  Saunders  (NOARL,  Code  331) 


* 

* 

* 

* 

* 

* 

* 

* 

* 

* 


INPUT 

Unit 

Filename 

Type 

Contents 

5 

SYS$INPUT 

KEYBOARD 

Control  Information 

12 

MODELl . DAT 

«  direct  » 

Data  to  plot 

12 

MODELl .UV 

«  direct  » 

UV  data  to  plot 

13 

MODELl .AUX 

«  ascii  » 

Descriptor  for  MODELl . DAT 

* 


OUTPUT  * 

C - 

C  Unit  Filename  Type  Contents 

C - 

C  6  SYS$OUTPUT  «cntl  window*  Program/control  information 

C  8  MODELl . PC  «ASCI I »  DATA  FOR  PC  PLOT  -  internally 

C  documented 

C************************************************************************ 


IMPLICIT  NONE 


INTEGERM  MAX,  IT 

PARAMETER  (MAX-500) 


CHARACTER *2  PLOT_TYPE 

CHARACTER* 8  PBOT,PTOP 

CHARACTER* 80  LABEL , LINE , CBUFF ( 20 ) 


REAL* 4 

1 


X, Y,X_SIDE, Y_SIDE, 

XMAX , YMAX , X0 , Y0 , DX , DY , ZP , ZM 


REAL* 4 


J , K , R , XLAST , XB , XE , YLAST , YB , YE , Z 


REAL *4 

1 

2 

3 

4 


T( MAX ) ,  S ( MAX ) ,  ZZ(MAX),  BV(MAX), 

ZD ( MAX , MAX ) , DT , DXX , DZZ , WM , WP , WT , HM , HP , HT , 
T_AV ( MAX ) , S_AV ( MAX ) , TD ( MAX , MAX ) , SD( MAX, MAX ) , 
SVEL , U ( MAX , MAX ) ,V(MAX,MAX) ,W(MAX,MAX) , 

UT ( MAX ) , VT ( MAX ) , WTT ( MAX ) 


INTEGER  *  4  NXX , NZ  Z , NT , I X , I Z , NVARS , LOC , I LOC , I BUFF ( 8  0 ) , I TMP 

INTEGER*4  NPTX , NPTY , N , I , IM, INX, INY 


DATA  J/17.0/ 

DATA  K/16/ 

EQUIVALENCE  ( ZD( 1 , 1 ) , U( 1 , J ) ) , ( TD( 1 , 1 ) , V( 1 , 1 ) ) , ( SD ( 1 , 1 ) , W( 1 , 1 ) ) 


EQUIVALENCE 


(UT{ 1) ,T( 1) ) , (VT( 1 ) , S( 1) ) , (WTT( 1) ,ZZ( 1) ) 


C  GET  INPUT  DATA  GENERATED  BY  MODELl 


1  FORMAT(A) 

OPEN  ( FILE* ' MODELl .  AUX' , UN IT" 13 , 
1  STATUS-'OLD' ,DISP«'KEEP' ) 


READ(13,1)  LINE 

READ(13,1)  LINE 

READ( 13,1)  LINE 

CALL  PARSE ( LINE, CBUFF,NVARS ) 

READ( CBUFF( 2)  ,*  )  NT 

READ (13/1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NXX 


READ( 13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ( CBUFF ( 2 ) , * )  NZZ 

READ (13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ( CBUFF ( 2 ) , * )  DT 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  DXX 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ( CBUFF( 2) ,* )  DZZ 


TYPE  *,  '  NT , NX , NZ , DT , DX , DZ  ' 

TYPE  *,  NT, NXX, NZZ 
TYPE  *,  DT, DXX, DZZ 

TYPE  *  ENTER  PLOT  TYPE  :  ZD,TD ,SD,SV  ' 


ACCEPT  1,  PLOT  TYPE 


TYPE  *,  '  ENTER  THE  TIME  ITERATION  NUMBER  ' 
ACCEPT  *,  IT 


I F (  PLOT_TYPE  .NE.  'U'  .AND.  PLOT_TYPE  .NE.  'V'  .AND 
1  PLOT_TYPE  .NE.  'W' )  THEN 

OPEN  ( FILE-'MODELl .DAT' , UNIT-12, 

1  STATUS-'OLD' ,DISP-' KEEP' , ACCESS- ' DIRECT' , 

2  FORM- ' UNFORMATTED ' , RECL-4  *NZZ ) 


DO  IX  -  1 , NXX 

LOC  -  NXX *(IT-1)  +  IX 

READ( 12 ' LOC ) ( ZD ( I , IX ) , T( I ) , S ( I ) , BV( I ) ,1-1 
DO  1 7.  ^  1 , NZZ 


************ 

* 

************ 


NZZ) 


TD(IZ,IX)  -  T(IZ) 

SD( IZ , IX)  -  S(IZ) 

T_AV ( I Z )  -  T_AV(IZ)  +  T( IZ ) 
S_AV ( I Z )  -  S  AV(IZ)  +  S( IZ ) 
END  DO 
END  DO 

DO  IZ  -  1 , NZZ 

T_AV ( I Z )  -  T_AV ( I Z ) /NXX 
S_AV ( I Z )  -  S  AV ( I Z ) /NXX 
END  DO  ~ 


DO  IX  -  1 , NXX 

DO  IZ  -  1,  NZZ 

IF(  PLOT_TYPE  .NE.  'SV')  THEN 

TD( IZ , IX)  -  TD( IZ , IX)  -  T  AV(IZ) 
SD( I Z , IX )  -  SD( IZ , IX)  -  S  AV(IZ) 

END  IF 
END  DO 
END  DO 


ELSE 

OPEN  (FILE-'MODELl.UV' , UNIT-12, 

1  STATUS* ' OLD ' ,DISP-'KEEP' , ACCESS- ' DIRECT ' , 

2  FORM- ' UNFORMATTED ' ,RECL-3*NZZ ) 


DO  IX  -  1 , NXX 

LOC  -  NXX* (IT-1)  +  IX 

READ( 12 ' LOC ) ( UT( I ) , VT{ I ) ,  WTT ( I ) , I— 1 , NZZ ) 

DO  IZ  -  1 , NZZ 

U(IZf IX)-UT(IZ) 

V ( I Z , I X ) — VT ( I Z ) 

W(  IZ , IX)— WTT ( IZ ) 

END  DO 
END  DO 

I F (  PLOT_TYPE  .EQ.  'V')  THEN 

DO  IX  •  1 , NXX 

DO  IZ  -  1 , NZZ 
ZD( IZ , IX )  -  V(IZ,IX) 

END  DO 

END  DO 
END  IF 

I F(  PLOT_TYPE  .EQ.  'W' )  THEN 

DO  IX  -  1 , NXX 

DO  IZ  -  1 ,  NZZ 
ZD( IZ , IX)  -  W(IZ,IX) 

END  DO 

END  DO 
END  IF 

END  IF 

OPEN  ( FILE— 'MODEL 1 .PC' , UNIT-8 , DISP- ' KEEP ' , STATUS- ' NEW' ) 

IF(  PLOT_TYPE  .EQ.  'TD'  .OR.  PLOT  TYPE  .EQ.  'SD'  .OR. 


1 


1 

1 


1 


PLOT_TYPE  .EQ.  'SV'  )  THEN 
DO  IX  -  1 , NXX 

DO  IZ  -  1 , NZZ 

IF(  PLOT  TYPE  .EQ.  'TD') 

ZD(IZ,IXT  -  TD(IZ,IX) 

I F (  PLOT  TYPE  .EQ.  'SD') 

ZD(IZ,IXT  -  SD(IZ,IX) 

I F (  PLOT  TYPE  .EQ.  'SV'  )  THEN 
ZD(IZ,IXT  -  SVEL( SD( IZ, IX) ,TD( IZ, IX) , 

( IZ— 1 ) *DZZ  ) 

I F ( IX  .EQ.  1)  S  AV(IZ)  -  0 
S_AV ( I Z )  -  S_AVllZ)  +  ZD( IZ , IX ) 

END  IF 


END  DO 

END  DO 


I F (  PLOT_TY?E  .EQ.  'SV'  )  THEN 
DO  IZ  -  1 , NZZ 

S_AV { I Z )  -  S_AV ( I Z )/NXX 

END  DO 


DO  IX  -  1 , NXX 

DO  IZ  -  1 , NZZ 

ZD ( I Z , IX )  -  ZD( IZ , IX)  -  S_AV ( I Z ) 

END  DO 

END  DO 
END  IF 


END  IF 


C  GET  INPUT  DATA  FOR  SCREEN  CONTROL  * 


NPTX*  640 
NPTY-  480 


XSIDE  -  NXX*DXX 
Y_SIDE  -  NZZ*DZZ 

DX  -  X_SIDE/NPTX 

DY  «  Y_SIDE/NPTY 

X0  -  0 
Y0  -  0 

XMAX  -  X_S IDE  -  DX 
YMAX  -  Y_S IDE  -  DY 

IF  (PLOT_TYPE  .EQ.  'ZD')  THEN 

LABEL  -  'VERTICAL  DISPLACEMENT  (m)' 
PBOT  -  '-10.0' 

PTOP  -  '10.0' 

END  IF 


I F  (  PLOT_TYPE  .EC’  'TD')  THEN 

LABEL  -  ' TEMPERATURE  ANOMALY  (°C)' 

PBOT  -  '-1.0' 

PTOP  -  '1.0' 

END  IF 

IF(  PLOTJTYPE  .EQ.  'SD')  THEN 

LABEL  -  'SALINITY  ANOMALY  (psu)' 

END  IF 

I F (  PLOTJTYPE  .EQ.  'SV')  THEN 

LABEL  -  '  SOUND  VELOCITY  ANOMALY  (m/S)' 

END  IF 

IF(  PLOT_TYPE  .EQ.  'U' )  THEN 

LABEL  -  ' HORIZNTAL  -U-  VELOCITY  (m/s)' 
END  IF 

IF{  PLOT_TYPE  .EQ.  'V'  )  THEN 

LABEL  -  'HORIZONTAL  -V-  VELOCITY  ( m/s ) ' 
END  IF 

I F (  PLOTJTYPE  .EQ.  'W'  )  THEN 

LABEL  -  '  VERTICAL  VELOCITY  (m/s)' 

END  IF 


WRITE (8, 2000 )  LABEL , NPTX , NPTY , PTOP , PBOT 
2000  FORMAT (  '  MODELl  -  SIMULATION  PLOT  DATA  '/ 

1  A80/ 

1  '  NPTX, ',110/ 

2  '  NPTY, ',110/ 

3  A10/ 

4  A10) 


DO  INX  -  1 , NPTX 

X  -  DX* ( INX— 1 ) 


IX  -  X/DXX  +  1 
I F ( IX  .LT.  1)  IX  -  1 
I F ( IX  .GT.  NXX )  IX  -  NXX 

WM  -  ABS ( ( IX-1 ) *DXX  -  X )/DXX 
WP  -  ABS ( IX*DXX  -  X)/DXX 
WT  -  WM+WP 
WM  -  1.0  -  WM/WT 
WP  -  1.0  -  WP/WT 

XLAST  «  X 
YLAST  -  Y0 
XB  -  X 
XE  -  X 
YB  -  Y0 
YE  -  Y0 

DO  INY  -  1 , NPTY 

Y  -  DYMINY-1) 

IZ  -  ( YMAX-Y ) /DZZ  +  1 

IF( IZ  .LT.  1)  IZ  -  1 

I F ( IZ  .GT.  NZZ)  IZ  -  NZZ 

HM  -  ABS ( ( IZ-1 ) *DZZ  -  ( YMAX-Y) )/DZZ 

HP  -  ABS (  IZ*DZZ  -  (YMAX-Y) )/DZZ 

HT  -  HM  +  HP 


HM  -  1.0  -  HM/HT 
HP  -  1.0  -  HP/HT 


IM  -  12-1 

IF(  IM.LE.DIM  -  1 


IF(  IX 

.GT. 

1) 

THEN 

ZP 

- 

(WP*ZD(IZf IX) 

ELSE 

ZM 

“ 

(WP*ZD{ IM, IX) 

ZP 

- 

ZD ( IZ, IX) 

END  IF 

ZM 

” 

ZD( IM, IX) 

Z  -  (HP*ZP  +  HM*ZM ) /( HM+HP 


+  WM*ZD( IZ , IX— 1 ) )/(WM+WP ) 
+  WM*ZD( IM, IX-1 ) )/( WM+WP ) 


IF  (PLOT  TYPE  .EQ. 

I  -  5.0*Z 
END  IF 

IF(  PLOT  TYPE  .EQ. 
I  -  50.*Z 

END  IF 

I F (  PLOT  TYPE  .EQ. 

I  -  500.*Z 
END  IF 

IF(  PLOT  TYPE  .EQ. 

I  -  50.0*Z 
END  IF 

I F (  PLOT  TYPE  .EQ. 

I  -  500.*Z 

END  IF 

I F (  PLOT  TYPE  .EQ. 
I  -  500.*Z 

END  IF 

I F (  PLOT  TYPE  .EQ. 
I  -  5000. *Z 
END  IF 


'ZD')  THEN 
'TD')  THEN 
'SD' )  THEN 
'SV')  THEN 
'U')  THEN 
'V'  )  THEN 
'W'  )  THEN 


IF(I.LE.O)  I  -  100  +  I 
I  -  ABS(I) 

I  -  I  -  (I/100)*100 
I F ( I  .LT.  1  )  I  -  0 
I F ( I  .GT.  99  )  I  -  99 


I LOC  -  ILOC  +  1 
IBUFF(ILOC)  -  I 
I F (  ILOC  .GE.  39)  THEN 

WRITE( 8 ,2010 )  ( IBUFF( ITMP ) , ITMP-1 , 39 ) 
ILOC  -  0 
END  IF 


l  Y 
l  X 

2010  FORMAT ( IX, 391 2  ) 


END  DO 
END  DO 


PAUSE 

STOP 

END 


REAL  FUNCTION  SVEL(S,T,P0) 

C  ******************************* 

C  SOUND  SPEED  SEAWATER  CHEN  AND  MILLERO  1977 , JASA, 62 , 1129-1135 
C  UNITS: 


on  nnooon 


PRESSURE 

PO 

DECIBARS 

TEMPERATURE 

T 

DEG  CELSIUS  (IPTS 

SALINITY 

S 

( IPSS-78 ) 

SOUND  SPEED 

SVEL 

METERS/SECCND 

CHECKVALUE:  SVEL-1731 . 995  M/S,  S-40  ( I PSS-78 ) , T-4 0  DEG  C, P-10000  DBAR 

EQUIVALENCE  { AO , BO , CO ) , ( Al , Bl , Cl ) , ( A2 , C2 ) , ( A3 , C3 ) 

SCALE  PRESSURE  TO  BARS 
P-P0/10. 

Q*  ************************  * 

SR  -  SQRT( ABS ( S )  ) 

C  S**2  TERM 

D  -  1.727E-3  -  7 . 9836E-6*P 
C  S**3/2  TERM 

Bl  -  7 . 3637E-5  +1.7945E-7*T 
BO  -  -1.922E-2  -4 . 42E-5*T 
B  -  BO  +  Bl*P 
C  S**l  TERM 

A3  -  (-3.389E-13*T+6.649E-12)*T+1.100E-10 
A2  -  ( (7.988E-12*T-1 . 6002E-10 ) *T+9 . 1041E-9 ) *T-3 . 9064E-7 
Al  -  ( ( (-2.0122E-10*T+1.0507E-8)*T-6.4885E-8)*T-1.2580E-5)*T 
X  +9.4742E-5 

AO  -  (  ( (-3.2lE-8*T+2.006E-6)*T+7.164E-5)*T-1.262E-2)*T 
X  +1.389 

A  -  (  (A3*P+A2)*P+Al)*P+A0 
C  S**0  TERM 

C3  -  (-2.3643E-12*T+3.8504E-10)*T-9.7729E-9 

C2  -  ( ( <1.0405E-12*T-2.5335E-10)*T+2.5974E-8)*T-1.7107E-6)*T 
X  +3 . 1260E-5 

Cl  -  ( ( (-6.1185E-10*T+1.3621E-7)*T-8.1788E-6)*T+6.8982E-4)*T 
X  +0.153563 

CO  -  ( ( ( (3.1464E-9*T-1.47800E-6)*T+3.3420E-4)*T-5.80852E-2)*T 
X  +5. 03711)* T+ 1402. 388 

C  -  ( (C3*P+C2)*P+C1)*P+C0 
C  SOUND  SPEED  RETURN 

SVEL  -  C  +  (A+B*SR+D*S)*S 

RETURN 

END 


nonnnnnnonnnnnnnnnnoonnonnn 


PROGRAM  M0DEL1  ENERGY 


*****'******************************************************************* 

* 

PROGRAM  M0DEL1_ENERGY  * 

* 

PURPOSE  COMPUTE  ENERGY  DENSITIES  AND  PLOT  MODEL  FIELDS  * 

* 

AUTHOR  K.D.  Saunders  (NOARL,  Code  331)  * 

* 

INPUT  * 

- * 

Unit  Filename  Type  Contents  * 

- - - — - - - - - - - - - - - - ★ 

5  SYS$INPUT  KEYBOARD  Control  Information  * 

12  MODELl.DAT  «  direct  »  Data  to  plot  * 

14  MODEL1.UV  «  direct  »  UVW  data  to  plot  * 

13  MODEL 1 .  AUX  «  ascii  »  Descriptor  for  MODELl.DAT  * 

- * 

* 


OUTPUT  * 

- * 


Unit 

Filename 

Type 

Contents 

* 

it 

6 

SYSSOUTPUT 

«  cntl  window  » 

Program/control  information 

it 

NA 

POPFIL.DAT 

«  DISSPLA  META 

FILE  »  Plot  information 

★ 

8 

ENERGY. LIS 

«  ASCII  » 

Summary  information 

* 

* 


INTEGER* 4  MAX 

PARAMETER  (MAX-500) 

CHARACTER* 80  LINE , CBUFF ( 20 ) , ANS 


INTEGER*4  N, I , NXX , NZ2 , NT, IX, IZ , NVARS , IPAK ( 2000 ) 


REAL*4 

1 

2 

3 

4 

5 

6 

7 

8 
9 
A 


T ( MAX ) ,  S ( MAX ) ,  BV ( MAX ) , 

ZD (MAX, MAX) , DT , DXX , DZZ , 

TD ( MAX , MAX ) ,SD(MAX,MAX) , 

U( MAX, MAX) , V ( MAX , MAX ) ,W(MAX,MAX) ,PI , 

Z2 ( MAX ) , U2 ( MAX ) , V2 ( MAX ) , EK_HOR ( MAX ) , EK_W( MAX ) , 
E_POT ( MAX ) , X ( MAX ) , EMAX , XMAX , W2 ( MAX ) ,EKAV,EPAV, 
UV_NORM,W_NORM, E  POT  Z ( MAX ) , EK_HOR_Z ( MAX ) , 
EK_W_Z ( MAX ) , ETOtTMAXT, 

J,K,R, RED, GREEN, 

Z ( MAX ) , EWEK_RATIO ( MAX ) , 

EPEK  RATIO ( MAX ) 


EQUIVALENCE  ( SD( 1 , 1 ) ,U( 1 , 1 ) ) , ( TD( 1 , 1 ) , V( 1 , 1 ) ) 

DATA  J/17.0/ 

DATA  K/16/ 


C  GET  INPUT  DATA  GENERATED  BY  MODELl  * 


FORMAT(A) 


PI  -4.0*ATAN(1.U) 

CR  -  ( 2*PI/3600 . 0 ) **2 

.  RHO  -  1025.0  !  NOMINAL  DENSITY  SEAWATER 

UV_NORM  -  0 
W_NORM  -  0 
NJNORN  -  0 

OPEN  ( FILE- ' MODELl .  AUX' , UNIT-1 3 , STATUS- ' OLD ' ,DISP-'KEEP' ) 

OPEN  (FILE- 'ENERGY. LIS' , UNIT-8 , STATUS- ' NEW' ,DISP-'KEEP' ) 

TYPE  * , '  IS  THIS  A  GENERIC  GM  BV  PROFILE  ?' 

ACCENT  1,  ANS 


READ (13,1)  LINE 

READ (13,1)  LINE 

READ( 13,1)  LINE 

CALL  PARSE ( LINE, CBUFF,NVARS) 

READ( CBUFF ( 2 ) , * )  NT 

READ( 13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS ) 

READ ( CBUFF ( 2 ) , * )  NXX 


READ ( 13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS ) 

READ ( CBUFF ( 2 ) , * )  NZZ 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ( CBUFF( 2 ) , * )  DT 

READ( 13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ(CBUFF(2) ,*)  DXX 

XMAX  -  DXX* ( NXX— 1 ) 

READ (13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  DZZ 


TYPE  *,  '  NT , NX , NZ , DT , DX , DZ  ' 

TYPE  *,  NT, NXX, NZZ 
TYPE  *,  DT, DXX, DZZ 

TYPE  *  ,'  ******  PLEASE  WAIT  -  READING  IN  DATA  *************' 


OPEN  ( FILE- 'MODELl .DAT' , UNIT-1 2 , STATUS- 'OLD' ,DISP-'KEEP' , 
1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' ,RECL-4*NZZ) 

OPEN  ( FILE- ' MODELl .UV' , UNIT-1 4 , STATUS- ' OLD ' ,DISP-'KEEP' , 

1  ACCESS-'DIRECT' , FORM- ' UNFORMATTED ' ,RECL-3*NZZ) 


C  ******  *  ************* * 

C  INITALIZE  VARIABLES  * 
£  ********************* 


EMAX  -  0 
EKAV  -  0 


EKHAV-  0 
EKWAV-  0 
EPAV  -  0 
ZAV  -  0 
N_NORM  -  0 
DO  IZ-  1 , MAX 

E_pOT_Z(xZ)  -  0 
EK_HOR  Z(IZ)  -  0 
EK_W_ZllZ)  -  0 
END  DO 

r 

C  READ  &  COMPUTE  VARIABLES  * 

DO  IX  -  1 , NXX 

X<IX)  -  ( IX-1 ) *DXX 
Z2 ( IX )  -  0 
TJ2  ( IX )  -  0 
V2 ( IX )  -  0 
W2(IX)  -  0 
E_POT ( IX )  -  0 

EK_HOR ( IX )  -  0 
EK_W ( IX )  -  0 

READ( 12 ' IX) ( ZD( I ,  IX) ,T( I ) ,S( I ) ,BV( I ) ,1-1, NZZ) 
READ( 14' IX) (U( I , IX) ,V( I , IX) ,W( I , IX) ,1-1, NZZ ) 


I F (  ANS  .EQ.  'YES')  THEN 
DO  I  -  1 , NZZ 

BV( I )  -  3 . 0*EXP(  -DZZ*( I-l)/1300.0) 

I F (  I.LT.4)  BV ( I )  -  2.99 

END  DO 
END  IF 

NZTOT  -  0 

DO  IZ  -  2, NZZ 

UV_NORM  -  UV_NORM  +  0 . 5* ( ABS ( U( IZ , IX ) ) +ABS { V( IZ , IX) ) ) 

W_NORM  -  W_NORM  +  ABS ( W( IZ , IX) ) 

Z_NORM  -  Z_NORM  +  ABS ( ZD( IZ , IX ) ) 

ZAV  -  ZAV  +  ZD( IZ , IX) 

N_NORM  -  N_NORM  +  1 

Z2  (  IX)  -  ?•  2  ( I X )  +  ZD(  I Z  ,  IX )  **2 
U2 { IX)  -  U2 ( IX )  +  U( IZ , IX ) **2 
V2(IX1  -  V2 ( IX )  +  V( IZ , IX) **2 
W2 ( IX )  -  W2 ( IX )  +  W( IZ , IX) **2 


1 


E_POT{ IX)-E_POT( IX)  + 

0 . 5*CR*BV( IZ ) *BV( IZ)*ZD(IZ,IX)**2 


1 

1 


EK_HOR_Z(IZ)  -  0 . 5*RHO* 

(U(IZ,IX)**2+V(IZ,IX)**2)+ 
EK  HOR  Z(IZ) 


EK_w_ZdZ)  -  0 . 5*RHO* 

1  W( IZ , IX) **2  +  EK_W_Z ( IZ ) 

E  POTJ(IZ)  -  E_POT_Z(IZ)  + 

0 . 5*RHO* 

CR*BV ( IZ ) *BV( IZ ) *ZD( ZZf IX)**2 


1 

1 


NZTOT-  NZTOT  +  1 


EK_HOR( IX ) *  0 . 5* ( U2 ( IX )  +  V2(IX)) 
EK  W(IX)  -  0 . 5*W2 ( IX ) 


EK_HOR( IX )  -  EK_HOR( IX ) *DZZ*RHO/NZZ 
EK_W( IX )  -  EK  W( IX)*DZZ*RHO/NZZ 

E_POT ( IX )  -  E_POT( IX) *DZZ*RHO/NZZ 

U2 ( IX)  -  U2 ( IX )/NZTOT 
V2 ( IX)  -  V2(IX)/NZT0T 
W2 ( IX )  -  W2 { IX )/NZTOT 
Z2 ( IX)  -  Z2 ( IX )/NZTOT 


I F (  EK_HOR{ IX)  .GT.  EMAX)  EMAX  -  EK_HOR(IX) 

I F (  E K_W (IX)  .GT.  EMAX)  EMAX  -  EK_W(IX) 

I F (  E_POT( IX)  .GT.  EMAX)  EMAX  -  E_POT(IX) 

EKHAV  -  EKHAV  +  EK_HOR(IX)  - 
EKWAV  -  EKWAV  +  EK  W(IX) 

EKAV-EKAV  +  EK_HORllX)  +  EK_W(IX) 

EPAV-EPAV  +  E  POT ( IX ) 


END  DO 


ZAV  -  ZAV/(NXX*NZZ ) 

U2AV  -  0 
V2AV  -  0 
W2AV  -  0 
Z2AV  -  0 
DO  IX  -  1 , NXX 

U2AV  -  U2AV  +  U2 ( IX ) 
V2AV  -  V2AV  +  V2 ( IX ) 
W2AV  -  W2AV  +  W2 ( IX ) 

Z2AV  -  Z2AV  +  Z2 ( IX ) 

END  DO 

U2AV  -  U2AV/NXX 
V2AV  -  V2AV/NXX 
W2AV  -  W2AV/NXX 
Z2AV  -  Z2AV/NXX 

UVRMS  -  SQRT( U2AV+V2AV) 

WRMS  -  SQRT( W2AV) 

ZRMS  -  SQRT(ABS( Z2AV  -  ZAV**2)) 

UV_NORM  -  UV_NORM/N_NORM 
W_NORM  -  W_NORM/N_NORM 
Z_NORM  -  Z_NORM/N_NOR»'l 

EKAV  -  EKAV/NXX 
EPAV  -  EPAV/NXX 
EKHAV  -  EKHAV/NXX 
EKWAV  -  EKWAV/NXX 

ETOTT  -  EKAV  +  EPAV 


WRITE ( 8 , 1000 )  EKAV, EKHAV, EKWAV, EPAV, ETOTT, 
1  UV_NORM,W_NORM,Z_NORM,ZAV, 

1  UVRMS, WRMS, ZRMS 

FORMAT ( //  '  EKAV  -  ',G’0.5/ 


1000 


1 

'  EKHAV- 

' , G20 . 5/ 

1 

'  EKWAV- 

' , G20 . 5/ 

T 

'  EPAV  - 

' ,G20 . 5/ 

1 

'  ETOT  - 

' , G20 . 5/// 

2 

'  UV  NORM 

-  ' , G20 . 5/ 

3 

'  W  NORM 

-  ' , G20 . 5/ 

3 

'  Z  NORM 

-  ' , G20 . 5/// 

4 

'  ZAV 

-  ' , G20 . 5/ 

4 

'  UVRMS 

-  ' , G20 . 5/ 

5 

'  WRMS 

-  ' ,G20 . 5/ 

6 

'  ZRMS 

-  ' , G20 . 5// ) 

EMAXZ  -  0 
ETOTMAX  -  0 
EKH_Z INT  -  0 
EP_ZINT  -  0 

EK_HOR_Z ( 1 )  -  EK_HOR_Z ( 1 ) /NXX 
E_p°T_Z(l)  -  E_POT_Z(l)/NXX 
ER_W_Z ( 1 )  -  EK_W_Z ( 1 ) /NXX 

DO  IZ  -  2 , NZZ 

EK_HOR_Z(IZ)  -  EK_HOR_Z ( I Z ) /NXX 
E_P°T_Z(IZ)  -  E_POT_Z ( I Z ) /NXX 
EK_W_Z(IZ)  -  EK_W_Z ( I Z ) /NXX 

IF(  E_POT_Z ( IZ )  .GT.  EMAXZ)  EMAXZ  -  E_POT_Z(IZ) 

I F (  EK_HOR  Z ( IZ ) . GT .  EMAXZ)  EMAXZ  -  EK_HOR  Z(IZ) 

IF(  EK_W  ZTlZ)  .GT.  EMAXZ)  EMAXZ  -  EK_W_ZTlZ) 

Z ( IZ )  -  Tiz-1)*dzz 

I F (  EK_HOR  Z(IZ)  .NE.  0)  THEN 
EWEK_RATIOllZ)  «  EK_W_Z(IZ)/EK_HOR_Z(IZ) 
EPEK_RATIO ( IZ )  -  E_POT  Z ( IZ )/EK_HOR_Z ( IZ ) 

ELSE 

EWEK_RATIO( IZ )  -  0 
EPEK_RATIO( IZ )  -  0 
END  IF 

ETOT(IZ)  -  E_POT_Z ( IZ ) +EK  HOR_Z ( IZ ) +EK_W_Z ( IZ ) 

I F (  ETOTMAX  .LT.  ETOT(IZ)J  ETOTMAX  -  ETOT(IZ) 
EKH_ZINT  -  EKH_ZINT  +  EK_HOR_Z ( IZ ) *DZZ 
EP_ZINT  -  EP_ZINT  +  E_POT_Z ( IZ ) *DZZ 

END  DO 

WRITE( *, 2000 )  EKH  ZINT,EP_ZINT 
2000  FORMAT (  '  Vertically  Integrated  HKE  -  ',gl6.4/ 

1  '  Vertically  integrated  PE  -  r,gl6.4//) 

DO  IZ  «  2, NZZ 

ETOT(IZ)  -  0.8*  EMAXZ*  ETOT( IZ ) /ETOTMAX 

END  DO 

ZMAX  -  DZZ* ( NZZ-1 ) 


C  DISSPLA  SUBPROGRAMS  * 

Q  *************************** 

CALL  COMPRS 

CALL  SETCL R( %REF( 'GREEN' ) ) 

CALL  PAGE (11. 0,8. 5) 

CALL  AREA2D( 8 . 0 , 4 . 0 ) 

CALL  TRIPLX 
CALL  HEIGHT( . 20 ) 

CALL  HEADIN( %REF( ' Internal  Wave  Ene rgy$ ' ) , 100 , 1 . 5 , 2 ) 
CALL  HEADIN( %REF( 'Horizontal  Distribution^ ' ) ,100, 1 .2,2 ) 
CALL  XNAME(%REF(  'Horizontal  Dir.l?nce  -  km$  '),100) 


CALL  YNAME( %REF( 'Energy  Level  -  J/m**2?  '),100) 

CALL  GRAF ( 0.0, %REF( 'SCALE' ) , XMAX ,0.0, %REF ( 'SCALE' ) , EMAX ) 

CALL  HEIGHT (0.1) 

CALL  LINES( %REF( 'Potential  Energy$ ' ) , IPAK, 1 ) 

CALL  LINES( %REF( 'Horizontal  Kinetic  Energy? ' ) , IPAK, 2 ) 

CALL  LINES( %REF{ 'Vertical  Kinetic  EnergyS ' ) , IPAK, 3 ) 

CALL  LEGLIN 
CALL  SCLPIC( 0.5) 

CALL  SETCLR(%REF( 'RED' ) ) 

CALL  CURVE (  X , E_POT , NXX , 20 ) 

CALL  SETCLR( %REF( 'YELLOW' ) ) 

CALL*JDASH 

CALL  CURVE (  X,EK  HOR,NXX,2C) 

CALL  SETCLR( %REFl'GREEN' ) ) 

CALL  DOT 

CALL  CURVE (  X, EK_W,NXX, 20 ) 

CALL  LEGEND ( I PAK , 3 , 6 . 0 , 3 . 0 ) 

CALL  ENDPL(O) 

CALL  RESET(%REF( 'ALL')) 

CALL  SETCLR( %REF( 'GREEN' ) ) 

CALL  PAGE (8. 5, 11.0) 

CALL  AREA2D ( 4 . 0 , 8 . 0 ) 

CALL  TRIPLX 
CALL  HEIGHT ( .20) 

CALL  HEADIN( %REF( ' Internal  Wave  EnergyS ' ) , 100 , 1 . 5 , 2 ) 

CALL  HEADIN( %REF( 'Vertical  Distribution? '), 100 , 1 . 2 , 2  ) 

CALL  YNAME( %REF( 'Depth  -  m?  '),100) 

CALL  XNAME( %REF( 'Energy  Level  -  J/m**2? ' ) , 100 ) 

CALL  GRAF (0.0, %REF ( ' SCALE ' ) , EMAXZ , Z ( NZTOT ) , %REF ( ' SCALE ' ) , 0 . 0 ) 
CALL  HEIGHT (0.1) 

CALL  LINES( %REF( 'Potential  Energy? '), IPAK , 1 ) 

CALL  LINES( %REF( 'Horizontal  Kinetic  EnergyS '), IPAK, 2 ) 

CALL  LINES( %REF( 'Vertical  Kinetic  Energy? '), IPAK , 3 ) 

CALL  LINES( %REF( 'Total  Energy? '), IPAK , 4 ) 

CALL  LEGLIN 
CALL  SCLPIC ( 0.5) 

CALL  SETCLR( %REF( 'RED' ) ) 

CALL  CURVE (  E_POT_Z ( 2 ) , Z ( 2 ) , NZTOT , 20 ) 

CALL  SETCLR( %REF( 'YELLOW' ) ) 

CALL  DASH 

CALL  CURVE (  EK_HOR_Z ( 2 ) , Z ( 2 ) , NZTOT , 2 0 ) 

CALL  SETCLR( %REF( 'GREEN' ) ) 

CALL  DOT 

CALL  CURVE (  EK_W_Z ( 2 ) , Z { 2 ) ,NZTOT, 20 ) 

CALL  CHNDOT 

CALL  CURVE (  ETOT( 2 ) , Z ( 2 ) , NZTOT, 20 ) 

CALL  LEGEND ( I PAK , 4 , 2 . 0 , 1 . 5 ) 

CALL  ENDPL(O) 

CALL  RESET( %REF( 'ALL' ) ) 

CALL  SETCLR( %REF( 'GREEN' ) ) 

CALL  PAGE (8. 5, 11.0) 

CALL  AREA2D { 4 . 0 , 8 . 0 ) 

CALL  TRIPLX 
CALL  HEIGHT ( .20) 

CALL  HEADIN( %REF( '  ENERGY  RATIOS  ? ' ) , 100 , 1 . 5 , 1 ) 

CALL  YNAME( %REF( 'Depth  -  m?  '),100) 

CALL  XNAME( %REF( 'Energy  Ratio?  '),100) 

CALL  GRAF ( 0.0, %REF( 'SCALE' ) , 1 . 0 , Z ( NZTOT ) , %REF ( 'SCALE' ) ,0.0) 
CALL  HEIGHT (0.1 ) 


CALL  LINES { %REF( ' WKE/HKE  Ratio$ ' ) , IPAK , 1 ) 
CALL  LINES ( %REF ( '  Pot . /HKE  Ratio$ ' ) , IPAK , 2 ) 
CALL  LEGLIN 
CALL  SCLPIC(O.S) 

CALL  S£TCLR( %REF( 'RED' ) ) 

CALL  CURVE {  EWEK  RATIO( 2 ) , Z ( 2 ) , NZTOT , 20 ) 
CALL  SETCLR( %REFl' YELLOW' ) ) 

CALL  DASH 

CALL  CURVE (  EPEK_RATIO( 2 ) , Z ( 2 ) , NZTOT, 20 ) 
CALL  LEGEND ( I PAK , 2 , 2 . 0 , 1 . 5 ) 

CALL  ENDPL(O) 


CALL  DONEPL 

STOP 

END 


ononnnnnonoooonnoononnnnonoonooo 


PROGRAM  M0DEL1_PL0T 

C**** ******************************************************************** 

* 

PROGRAM  M0DEL1  PLOT  * 

* 

PURPOSE  COMPUTE  AND  PLOT  MODEL  FIELDS  * 

* 

AUTHOR  K.D.  Saunders  (NOARL,  Code  331)  * 

* 


INPUT 

* 

Unit 

Filename 

Type 

Contents  * 

5 

12 

12 

13 

SYS$INPUT 
MODELl.DAT 
MODELl .UV 
MODEL1.AUX 

KEYBOARD 
«  direct  * 

«  direct  » 

«  ascii  » 

Control  Information  * 
Data  to  plot  * 
UV  data  to  plot  * 
Descriptor  for  MODELl.DAT  * 

OUTPUT 

* 

* 

Unit 

Filename 

Type 

Contents  * 

6 

NA 

SYS$OUTPUT 
SYS$WORK STATION 

«cntl  window* 
•plot  window* 

Program/control  information  * 

Color  plots  * 

* 

* 

Notes:  * 

This  program  is  designed  to  be  used  on  the  DEC  GKS  * 

Workstation  2000.  It  will  not  work  on  any  other  system  * 

* 

* 

************************************************************************ 


IMPLICIT  NONE 

INCLUDE  ' SYS$LIBRARY :UI SENTRY' 

INCLUDE  ' SYS$LIBRARY : UI SUSRDEF ' 

INTEGERM  MAX,  IT 

PARAMETER  ( MAX- 500) 


LOGICAL*!  DRAW, INSIDE, NEW, INSIDELAST  /.FALSE./ 


1 

2 

3 

4 


CHARACTER* 2  PLOT_TYPE 

CHARACTER* 8  PBOT,PTOP 

CHARACTER* 80  MY_FONTl , LABEL , NUMBER 

CHARACTER* 80  XTITLE  /'X$'/, 

YTITLE  /'Y$'/, 
ZTITLE, 

LINE, 

CBUFF ( 20 ) 


1 

1 


REAL* 4 


X,Y,X_SIPE,Y_SIDE 
XMAX , YMAX , 

X0, Y0,DX,DY, 


1 


XFACT , YFACT ,  ZP , ZM , WWW , X  OFF , Y  OFF 


REAL *4 

1. 


J , K , R , RED , GREEN , BLUE , DEG , SX , S Y , 
XLAST , XB , XE , YLAST , YB , YE , Z 


REAL* 4 

1 

2 

3 

4 


T( MAX) ,  S ( MAX ) ,  ZZ(MAX),  BV(MAX), 

ZD (MAX, MAX) , DT , DXX , DZZ , WM , WP , WT, HM, HP , HT , 
T_AV ( MAX ) , S_AV ( MAX ) , TD ( MAX , MAX ) ,SD(MAX,MAX) , 
5VEL , U ( MAX , MAX ) , V( MAX, MAX) ,W(MAX,MAX) , 

UT( MAX ) , VT { MAX ) , WTT ( MAX ) 


REAL  *  4  DZ, FACTOR, OFFSET, SXB , SYB , SYE , Q, XT, ZMIN,ZMAX 

REALM  TMPX,  TMPY,  PIX_SIZE 


INTEGERM 

INTEGERM 

1 

2 


DATA  J/17.0/ 

DATA  K/16/ 

DATA  VCM_S I Z  E/1 30/ 

EQUIVALENCE  ( ZD( 1 , 1 ) ,U( 1 , 1 ) ) , ( TD( 1 , 1 ) ,V( 1 , 1 ) ) , ( SD( 1 , 1 ) ,W( 1 , 1 ) ) 

EQUIVALENCE  ( UT( 1 ) , T( 1 ) ) , ( VT( 1 ) , S ( 1 ) ) , (WTT(l) ,ZZ(1) ) 

MY_FONTl-'DVWSVT0G03CK00GG0001QZZZZ02A000' 

C  GET  INPUT  DATA  GENERATED  BY  MODELl  * 


NXX , NZ  Z , NT , I X , I Z , NVARS , LOC 

I_INDEX{ 10,10,10) ,NPTX, NPTY, 
VCM_SIZE,VD_ID,WD_ID,WD_ID2,N,I,VCM_ID, 
I LAST , NITER , IXB , IXE , I YB , I YE , IM 


1  FORMAT(A) 

OPEN  ( FILE-'MODELl .AUX' , UNIT-13, 
1  STATUS-'OLD' ,DISP-'KEEP' ) 


READ( 13,1)  LINE 

READ (13,1)  LINE 

READ( 13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NT 

READ( 13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ ( CBUFF ( 2 ) , * )  NXX 


READ( 13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ( CBUFF ( 2 ) , * )  NZZ 

READ' 13,1)  LINE 

CALL  PARSE (LINE, CBUFF, NVARS) 

READ( CBUFF( 2 ) , * )  DT 

READ( 13,1)  LINE 

CALL  PARSE ( LINE, CBUFF, NVARS) 


n  n 


READ(CBUFF(2) ,*)  DXX 


READ(13,1)  LINE 

CALL  PARSE ( LI NE , CBUFF , NVARS ) 

READ ( CBUFF (  2  )  ,  *  )  DZZ 


TYPE  *,  '  NT , NX , NZ , DT , DX , DZ  ' 

TYPE  *,  NT , NXX , NZZ 
TYPE  *,  DT, DXX, DZZ 

TYPE  *  ,'  ENTER  PLOT  TYPE  :  ZD,TD,SD,SV  ' 


ACCEPT  1,  PLOT_TYPE 

degugging  "goto"  2/29/89 
go  to  1001 

TYPE  *,  '  ENTER  THE  TIME  ITERATION  NUMBER  ' 
ACCEPT  *,  IT 


I F (  PLOT_TYPE  .NE.  'U'  .AND.  PLOT_TYPE  .NE.  'V'  .AND. 
1  PLOT_TYPE  .NE.  'W' )  THEN 

OPEN  ( FILE-'MODELl . DAT' , UNIT-12, 

1  STATUS* ' OLD ' ,DISP-'KEEP' , ACCESS- ' DIRECT ' , 

2  FORM-' UNFORMATTED ' ,RECL-4*NZZ ) 


DO  IX  -  1 , NXX 

LOC  -  NXX* ( IT-1 )+IX 

READ( 12 ' LOC  M  ZD( I , IX ) ,T(I) ,S(I) , BV( I ) , I  — 1 , NZZ ) 
DO  IZ  -  1 , NZZ 

TD ( IZ , IX )  -  T( IZ ) 

SD ( IZ , IX )  -  S(IZ) 

T_AV ( I Z )  -  T_AV ( I Z )  +  T( IZ ) 

S_AV ( I Z )  -  S_AV ( I Z )  +  S(IZ) 

END  DO 
END  DO 


DO  IZ  -  1 , NZZ 

T_AV( IZ ) 
S_AV ( IZ ) 

END  DO 


T_AV( IZ )/NXX 
S  AV { IZ )/NXX 


DO  IX 

-  1 , NXX 

DO 

IZ  -  1,  NZZ 

IF(  PLOT  TYPE 

.NE. 

,  'SV' 

) 

THEN 

TD( IZ, 

IX) 

-  TD( 

IZ 

,IX)  - 

-  T  AV  ( 

IZ) 

SD ( IZ, 

IX) 

-  SD( 

IZ 

,IX)  - 

-  S_AV ( 

IZ) 

END  IF 

END  DO 
END  DO 


ELSE 


OPEN  ( FILE-'MODELl .UV' , UNIT-12, 

STATUS- 'OLD' ,DISP-'KEEP' , ACCESS- ' DIRECT' , 
FORM- 'UNFORMATTED' ,RECL-3*NZZ ) 


1 

2 


DO  IX  -  1 , NXX 

LOC  -  NXX* (IT-1)  +  IX 

READ (12' LOC ) ( UT ( I )  , VT ( I ) ,WTT( I ) , 1-1 , NZZ ) 
DO  IZ  -  1 , NZZ 

U(IZ,IX)-UT(IZ) 

V ( I Z , I X ) ■ VT ( I Z ) 

W(IZ,IX)-WTT(IZ) 

END  DO 
END  DO 

I F (  PLOT_TYPE  .EQ.  'V' )  THEN 

^  DO  IX  -  1 , NXX 

DO  IZ  «  1 , NZZ 
ZD ( I Z , IX )  -  V(IZ,IX) 

END  DO 

END  DQ 
END  IF 

IF (  PLOT_TYPE  .EQ.  'W' )  THEN 

DO  IX  -  1 , NXX 

DO  IZ  -  1 , NZZ 
ZD( IZ , IX )  -  W(IZ,IX) 

END  DO 

END  DO 
END  IF 

END  IF 


I F (  PLOT_TYPE  .EQ.  'TD'  .OR.  PLOT_TYPE  .EQ.  'SD'  .OR. 
PLOTJTYPE  .EQ.  'SV'  )  THEN 
DO  IX  -  1 , NXX 

DO  IZ  -  1 , NZZ 

I F (  PLOT  TYPE  .EQ.  'TD') 

ZD(IZ,IXl  -  TD ( IZ , IX ) 

I F (  PLOT  TYPE  .EQ.  'SD') 

ZD(IZ,IXT  -  SD ( I Z , IX ) 

I F (  PLOT  TYPE  .EQ.  'SV'  )  THEN 
ZD(IZ,IXT  -  SVEL( SD( IZ , IX) ,TD( IZ , IX) , 

( IZ-1 ) *DZZ  ) 

I F ( IX  .EQ.  1)  S  AV(IZ)  -  0 
S_AV ( I Z )  -  S_AVTlZ)  +  ZD(IZ,IX) 

END  IF 


END  DO 

END  DO 


1 

1 

1 

1 


I F (  PLOTJTYPE  .EQ.  'SV'  )  THEN 
DO  IZ  -  1 , NZZ 

S_AV ( I Z )  -  S_AV ( I Z ) /NXX 

END  DO 


DO  IX  -  1 , NXX 

DO  IZ  -  1 , NZZ 

ZD( IZ , IX)  -  ZD(IZ,IX)  -  S  AV(IZ) 
END  DO  ~ 

END  DO 


END  IF 


noon 


END  IF 


c  continue  here  for  debugging  goto  2/29/89 
1001  continue 

C  GET  INPUT  DATA  FOR  SCREEN  CONTROL  * 

Q*  **********************************************************************  * 


TYPE  *,  '  ENTER  SCREEN  SIZE  IN  CM  ' 

ACCEPT  *,SX 

TYPE  *,'  ENTER  NO  POINTS  ON  SCREEN  IN  X  AND  Y  DIRECTIONS  ' 
ACCEPT  *,  NPTX,NPTY 


SX  -  34.0 
SY  -  28.5 
NPTX«  1000 
NPTY-  1000 


XSIDE  -  NXX*DXX 
Y_SIDE  -  NZZ*DZZ 

PIXSIZE  -  29.38 

XFACT  -  PIX_SIZE*<SX/X_SIDE)*0.9 
YFACT  -  PIX_SIZE* ( SY/Y  SIDE) *0.9 
XOFF  -  PIX_SIZE* ( 0 . 05j*SX 
Y  OFF  -  PIX  SIZE* ( 0 . 05 ) *SY 


DX  -  X_S I DE/NPTX 

DY  «  Y  SIDE/NPTY 


X0  -  0 
Y0  -  0 

XMAX  -  X_SIDE  -  DX 
YMAX  -  Y  SIDE  -  DY 


C  SET  UP  PLOTTING  FEATURES 


VCM_ID  -  UIS$CREATE_COLOR_MAP( VCM_SIZE) 

C  GET  BETTER  SCALING 

TMPX  -  -0 . 05*X_SIDE 
TMPY  -  -0 . 05*Y_SIDE 

C  VD_ID  -  UI S$CREATE_DISPLAY (0,0, XMAX , YMAX , SX , SX , VCM_ID ) 

VD_ID  -  UIS$CREATE_DISPLAY ( TMPX , TMPY, XMAX-TMPX, YMAX-TMPY , 

1  SX , S Y , VCM_I D ) 

WD  ID  -  UISSCREATE  WINDOW(VD  ID, ' SYS$WORKSTATION f , 'WINDOW  #1') 


DO  N  -  1,124 

DEG  -  N* 360 .0/124 .0  +  60.0 


nnocjno  on 


END  DO 


IF(  DEG  .GT.  360.0)  DEG  -  DEG  -  360.0 

CALL  UI  S$HSV_TO_P.GB  (  DEG ,  1 . 0 , 1 . 0  ,  RED ,  GREEN ,  BLUE  ) 

CALL  UIS$SET_COLOR(VD  ID , N, RED , GREEN , BLUE ) 


C  CREATE  BLACK 

CALL  UIS$SET_COLOR( VD_ID, 101 ,0.0,0. 0,0.0) 
C  CREATE  WHITE 

CALL  UIS$SET_COLOR( VD_ID, 102 ,1.0, 1.0, 1.0) 
DO  I*"-  1,124 

CALL  UIS$SET_WRITING  INDEX(VD  ID, 0,1, I) 
END  DO 


"GO  TO  1000"  FOR  DEBUGGING  PURPOSES  2/28/89  SAB 
GO  TO  1000 


******************************** 

DRAW  A  BOX  AROUND  THE  AREA  * 

******************************** 

CALL  UI S$SET_LINE_WIDTH ( VD  I D , 1 0 2 , 1 0 2 , 4 . 0 , UI S$C  WIDTH  PIXELS) 
CALL  UIS$PLOT(VD_ID, 102,0.7, 0.0,  XMAX,0.0, 

1  X.MAX ,  YMAX ,  0.0,  YMAX,  0.0, 0.0) 


DO  X  -  0 , XMAX , DX 

IX  -  X/DXX  +  1 
I F ( IX  .LT.  1)  IX  -  1 
IF( IX  .GT.  NXX )  IX  -  NXX 

WM  -  ABS ( ( IX— 1 ) *DXX  -  X ) /DXX 
WP  -  ABS ( IX* DXX  -  X ) /DXX 
WT  -  WM+WP 
WM  -  1.0  -  WM/WT 
WP  -  1.0  -  WP/WT 

XLAST  -  X 
YLAST  -  Y0 
XB  -  X 
XE  -  X 
YB  -  Y0 
YE  -  Y0 
NEW  -.TRUE. 

DRAW  -  .FALSE. 


DO  Y  -  0 , YMAX, DY 


IZ  -  ( YMAX-Y ) /DZZ  +  1 

I F ( I Z  .LT.  1)  IZ  -  1 

I F ( I Z  .GT.  NZZ)  IZ  -  NZZ 

HM  -  ABS { ( I Z-l ) *DZZ  -  ( YMAX-Y ) )/DZZ 

HP  -  ABS (  IZ*DZZ  -  ( YMAX-Y) )/DZZ 

HT  -  HM  +  HP 

HM  -  1.0  -  HM/HT 

HP  -  1.0  -  HP/HT 


C  I F {  IX  .EQ.  1  .AND.  IZ.LT.  10)  THEN 

C  TYPE  *,  'YMAX-Y, IZ,HM, HP' , YMAX-Y, IZ,HM, HP 

C 


END  IF 


IM  -  IZ-1 
I F ( IM . LE . 1 ) IM  -  1 


I F ( IX  .GT.  1)  THEN 

ZP  -  ( WP*ZD( IZ , IX )  +  WM*ZD( IZ , IX-1 ) )/( WM+WP ) 
ZM  -  (WP*ZD( IM,IX)  +  WM*ZD( IM, IX-1 ) )/( WM+WP ) 

ELSE 

ZP  -  ZD ( I Z , IX ) 

ZM  -  ZD(IM,IX) 

END  IF 

^  Z  -  ( HP*ZP  +  HM*ZM ) /( HM+HP ) 

C  DEFAULT  COLOR  SCALE  UNIT  LABELS 

PBOT  -  '-0.1' 

PTOP  -  '0.1' 

IF  (PLOT  TYPE  .EQ.  'ZD')  THEN 
I  -  5.0*Z 

LABEL  -  'VERTICAL  DISPLACEMENT  (.m)  ' 

PBOT  -  '-10.0' 

PTOP  -  '10.0' 

END  IF 

IF (  PLOT  TYPE  .EQ.  'TD')  THEN 
I  -  50. *Z 

LABEL  -  'TEMPERATURE  ANOMALY  (°C)' 

PBOT  -  '-1.0' 

PTOP  -  '1.0' 

END  IF 

I F (  PLOT  TYPE  .EQ.  'SD')  THEN 
I  -  500.*Z 

LABEL  -  'SALINITY  ANOMALY  ( psu ) ' 

END  IF 

I F (  PLOT  TYPE  .EQ.  'SV')  THEN 
I  -  50.0*Z 

LABEL  -  '  SOUND  VELOCITY  ANOMALY  (m/s)' 

END  IF 

I F (  PLOT  TYPE  .EQ.  'U' )  THEN 

I  -  5oo.*z 

LABEL  -  ' HORIZNTAL  -U-  VELOCITY  (m/s)' 

END  IF 

I F (  PLOT  TYPE  .EQ.  'V'  )  THEN 
I  -  500.*Z 

LABEL  -  'HORIZONTAL  -V-  VELOCITY  (m/s)' 

END  IF 

I F (  PLOT  TYPE  .EQ.  'W'  )  THEN 
I  -  5000. *Z 

LABEL  -  '  VERTICAL  VELOCITY  (m/s)' 

END  IF 

IF(I.LE.O)  I  -  100  +  I 
I  -  ABS(I) 

I  -  I  -  (I/100)*100 
I F ( I  . LT .  1  )  I  -1 
I F( I  .GT.  100  )  I  -  100 

C  I  -  2* ( 1/2 ) 


I F (  NEW  )  THEN 

NEW  -  .FALSE. 
I LAST  -  I 
XLAST  -  X 
YLAST  -  Y 


END  IF 


I F (  I  .NE.  I LAST )  THEN 
XE  -  XLAST 
YE  -  YLAST 
DRAW  -  .TRUE. 

END  IF 

I F (  Y  .GT.  YMAX-DY )  THEN 
XE-  X 
YE  -Y 

DRAW  -  .TRUE. 

END  IF 


I F (  DRAW  ) THEN 


C 


CALL  UIS$PLOT( VD  ID , ILAST , XB , YB , XE , YE ) 


IXB  -  XFACT*XB  +  X_OFF 
IXE  -  XFACT*XE  +  X_OFF 
I YB  -  YFACT*YB  +  Y_OFF 
I YE  -  YFACT*YE  +  Y_OFF 

CALL  UISDC$PLOT(WD_ID, ILAST, IXB, 
1  I YB , IXE , I YE ) 

XB  -  X 
YB  -  Y 

DRAW  -  .FALSE. 

END  IF 

XLAST  -  X 
YLAST  -  Y 
ILAST  -  I 

END  DO 
END  DO 

C  CONTINUE  HERE  FOR  DEBUGGING  2/28/89 
1000  CONTINUE 

C  CREATE  BACKGROUND  FOR  COLOR  SCALE 
DZ  -  .05 

FACTOR  -  XMAX/2  50 . 0 
OFFSET  -  ( 4 . 5/6 . 0 ) *XMAX 
SYB  -  TMPY 
SYE  -  300.0 

DO  XT  -  -50 , 50 , DZ 

X  -  FACTOR*XT  +  OFFSET 
I  -  XT 

IF  (I  .LT.  0)  I  -  I  +  100 
CALL  UIS$PLOT( VD_ID , 102 , X , SYB , X , SYE ) 

END  DO 

C  CREATE  COLOR  SCALE 

OFFSET  -  ( 4 . 5/6 . 0 ) *XMAX 
FACTOR  -  XMAX/300 . 0 
SYB  -  0.0 
SYE  -  100.0 

DO  XT  -  -50 , 50 , DZ 

X  -  FACTOR*XT  +  OFFSET 
I  -  XT 

IF  (I  .LT.  0)  I  - 


I  Y 
!  X 


I  +  100 


n  n  n  n 


CALL  UI S$PLOT ( VD_I  D , I , X , S YB , X , S YE ) 
END  DO 


C  SETUP  FONTS  FOR  WRITING 

CALL  UIS$SET_FONT(VD_ID,0,1,MY  FONTl ) 

CALL  UIS$NEW_TEXT_LINE( VD_ID, 4T 

FOR  DEGUGGING 

LABEL  -  'TEMPERATURE  TEST' 

PBOT-  '-10.0' 

PTOP  -  '10.0' 

C  LABEL  PLOT  TITLE 

X  -  -50*FACTOR  +  OFFSET 

call  ui s$set_char_si ze ( VD_ID, 101,103, , ,75.0) 
CALL  UIS$TEXT( VD_ID , 103 , LABEL , X , SYE+200 ) 

C  LABEL  COLOR  SCALE  UNITS 

call  uis$set_char_size(VD_ID,101,103, , ,70.0) 

X  -  -50*FACTOR  +  OFFSET  -  .9 

CALL  UISSTEXT ( VD_ID , 103 , PBOT ,X,SYE+100) 

X  -  OFFSET  -  .5 

CALL  UIS$TEXT( VD_ID, 103 , '0' ,X,SYE+100) 

X  -  50 *FACTOR  +  OFFSET  -  .9 

CALL  UI S$TEXT ( VD  ID , 1 0 3 , PTOP , X, SYE+1 00 ) 


C  LABEL  HORIZONTAL  AXIS 

LABEL  -  'HORIZONTAL  DISTANCE  (km)' 

X  -  XKAX/3.0 

call  uis$set_char_size(VD_ID,102,103, , ,75.0) 

CALL  UIS$TEXT(VD_ID, 103, LABEL, X,YMAX  +  150.0) 

DO  I  -  0,40,10 
X  -  I 

PTOP  -  NUMBER ( I ) 

call  uis$set_char_size(VD_ID,103,103, , ,70.0) 
CALL  UIS$TEXT(VD_ID, 103, PTOP, X,YMAX  +  80.0) 

END  DO 


C  LABEL  VERTICAL  AXIS 

LABEL  -  'DEPTH  (m)' 
X  -  YMAX/2.5 


call  ui s$set_char_si ze ( VD  ID, 102 , 103 , , , 75 . 0 ) 
call  uis$set_text_slope{ v3_id,103 ,103,90.0) 

CALL  UIS$TEXT( VD_ID, 103 , LAB EL, -2 . 0 ,X) 

DO  I  -  0,3000,1000 
X  -  I 

PTOP  -  NUMBER( 3000-1 ) 

call  uis$set_char_size ( VD_ID, 103 , 103 , , , 70 . 0 ) 
CALL  UIS$TEXT( VD_ID, 103 , PTOP, -1 . 3,X) 

END  DO 


PAUSE 

STOP 


no  o  n  r>  n  o  o  o  n  o 


END 


REAL  FUNCTION  SVEL(S,T,P0) 

**  *  ** ************************** 

SOUND  SPEED  SEAWATER  CHEN  AND  MILLERO  1977 , JASA, 62 , 1129-1135 
UNITS: 


PRESSURE 

PO 

DECIBARS 

TEMPERATURE 

T 

DEG  CELSIUS  ( IPTS 

SALINITY 

S 

( IPSS-78) 

SOUND  SPEED 

SVEL 

METERS/SECOND 

CHECKVALUE:  SVEL-1731 . 995  M/S,  S-40  ( IPSS-78 ) ,T-40  DEG  C, P-10000  DBAR 

EQUIVALENCE  ( AO , BO , CO ) , ( Al , Bl , Cl ) , ( A2 , C2  )  ,  ( A3  ,  C3  ) 

SCALE  PRESSURE  TO  BARS 
P-P0/10. 

Q* ************************* 

SR  -  SQRT(ABS( S ) ) 

C  S**2  TERM 

D  -  1.727E-3  -  7 . 9836E-6*P 
C  S**3/2  TERM 

Bl  -  7 . 3637E-5  +1.7945E-7*T 
BO  -  -1.922E-2  -4 . 42E-5*T 
B  -  BO  +  Bl  *P 
C  S**l  TERM 

A3  -  (-3.389E-13*T+6.649E-12)*T+1.100E-10 
A2  -  ( (7.988E-12*T-1.6002E-10)*T+9.104lE-9)*T-3.9064E-7 
Al  -  ( ( (-2.0122E-10*T+1.0507E-8)*T-6.4885E-8)*T-1.2580E-5)*T 
X  +9 . 4742E-5 

AO  -  ( ( (-3.21E-8*T+2.006E-6)*T+7.164E-5)*T-1.262E-2)*T 
X  +1.389 

A  -  ( (A3*P+A2)*P+A1)*P+A0 
C  S**0  TERM 

C3  -  (-2.3643E-12*T+3.8504E-10)*T-9.7729E-9 

C2  -  ( ( (1.0405E-12*T-2.5335E-10)*T+2.5974E-8)*T-1.7107E-6)*T 
X  +3.1260E-5 

Cl  -  ( ( (-6.1185E-10*T+1.3621E-7)*T-8.1788E-6)*T+6.8982E-4)*T 
X  +0.153563 

CO  -  ( ( ( (3.1464E-9*T-1.47800E-6)*T+3.3420E-4)*T-5.80852E-2)*T 
X  +5. 03711)* T+ 1402. 388 
C  -  ( (C3*P+C2)*P+C1)*P+C0 
C  SOUND  SPEED  RETURN 

SVEL  -  C  +  (A+B*SR+D*S)*S 

RETURN 

END 


nooooooonnonoonooononnnoooooononoonnon 


****************************  ****************  *  ************************* 


*  l. 


★ 

PROGRAM  DISPERSION  * 

* 

PURPOSE  Produces  modal  dispersion  diagrams  for  a  Brunt-  * 

Vaisala  frequency  profile  at  a  given  location  and  * 

season,  * 

* 

AUTHOR ( S )  K . D .  Saunders  (NOARL)  * 

* 


INPUT 


*  * 
*  * 
* 
* 

_* 


UNIT  FILE  DATA  * 

_ _ _ _ _ _ _ _ _ * 


5  SYS$ INPUT 


10  LEVITUS.DAT 


«  Ephemeral  input  file  -  keyboard 


* 

* 


1. 

Starting  Latitude 

( decimal 

8) 

2. 

Starting  Longitude 

( decimal 

°) 

3. 

Direction  of  section 

(  0  from 

north ) 

4. 

Max  Range  ( xmax ) 

(  km  ) 

5. 

Max  Depth  (zmax) 

(  m  ) 

6. 

Delta  x 

(  km  ) 

7. 

Delta  z 

(  m  ) 

8. 

Max  time 

(  s  ) 

9. 

Delta  time 

(  s  ) 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 


* 

«  DIRECT  ACCESS*  * 

* 

Base  Temperature  and  Salinity  Profiles  needed  to* 
define  the  field  of  Brunt-Vaisala  frequencies.  * 
along  the  section.  * 

* 


oonooooonoonoooo 


OUTPUT 

Unit  FILE  DATA 

6  SYS$OUTPUT  «  ephemeral  file  » 

1.  Diagnostic  information 

11  TEST_DIAGNOSTICS . LIS  «  ASCII  file  • 

1.  Diagnostic  information 
??  POPFIL.DAT  1.  DISSPLA  meta  file 


onoooonoooononnnoonnnooonnonnnnnnon 


************************************************************************ 

************************************************************************ 

* 

* 

NOTES  * 

1.  The  following  assumptions  are  made  for  this  first  level  * 

model:  * 

* 

n  no  mean  currents  are  assumed.  * 

(this  restriction  will  be  relaxed  in  later  versions)  * 

* 

-  -A** 

n  only  the  internal  wave  part  of  the  spectrum  affects  the  * 

fields  of  temperature  and  salinity.  * 

(this  restriction  will  be  relaxed  in  later  versions)  * 

* 

°  the  temperature  and  salinity  fields  are  initially  defined  * 
based  on  the  Levitus  5°  data  base  averages.  * 

(this  restriction  will  be  relaxed  in  later  versions)  * 

* 

n  if  the  BV  frequency  is  imaginary,  it  is  set  to  zero  in  the  * 
mode  calculations.  * 

* 

°  the  internal  wave  field  does  not  affect  the  modes  for  t  >  0  * 

(this  restriction  will  be  relaxed  in  later  versions)  * 

* 

2.  The  profile  input  section  is  derived  from  programs  written  * 

by  William  Teague,  NOARL,  Code  331  in  conjunction  with  the  * 
MOODS  data  base  project.  * 

* 

3.  The  internal  wave  simulation  section  is  derived  from  programs* 

written  by  Dr.  David  Rubenstein  ,  SAIC  * 

* 

* 

************************************************************************ 

ft*********************************************************************** 


IMPLICIT  NONE 


CHARACTERS  TIMEBUFF 

REAL* 4  TTTO , DTTT 

INCLUDE  ' MODELl . INC ' 


TTTO  -  SECNDS (0.0) 


CALL  CONTROL_INPUT 
CALL  PROFI LE_INPUT 
CALL  I NT_WAVE_S I MULATI ON 

CALL  TIME ( TIMEBUFF ) 

DTTT  -  SECNDS (TTTO) 

WRITE( 11,100)  TIMEBUFF, DTTT/60. 

100  FORMAT (  /////'  ENDING  TIME  -  ' 

1  '  ELASPED  TIME (MIN )  -  ' 


STOP 

END 


0 

,A8  / 

, G20 . 5  ) 


nnnnnnnnonnnoonnonnnnnonnnnnonooonnooonoon 


FILE  DATA 


SYS$INPUT  1.  Starting  Latitude  (decimal  °) 

2.  Starting  Longitude  (decimal  °) 

3.  Direction  of  section  (  0  from  north) 

4.  Max  Range  (xmax)  (  km  ) 

5.  Max  Depth  ( zmax )  (  m  ) 

6.  Delta  x  (  km  ) 

7.  Delta  z  (  m  ) 

8.  Max  time  (  s  ) 

9.  Delta  time  (  s  ) 

*********************************************************************** 

OUTPUT 


FILE  DATA 


SYS$OUTPUT  1.  Diagnostic  information 

* 

COMMONS  1.  All  output  is  passed  through  named  common  * 

************************************************************************ 

IMPLICIT  NONE 
CHARACTER*  8  TIMEBUFF 

INTEGER* 4  IANG 

REAL *4  SINE, COSE 

INCLUDE  'MODELl.INC' 


OPEN  ( FILE«TERMINAL_INPUT, UNIT-5,  STATUS-' UNKNOWN' , DI SP- ' DELETE ' ) 
OPEN  ( FILE-TERMINAL_OUT  , UNIT-6 , STATUS- ' UNKNOWN ', DISP- ' DELETE ' ) 
OPEN  (FILE- 'TEST  DIAGNOSTICS . LIS ' , UNIT-11 , STATUS- ' NEW' , DISP- 'KEEP' ) 


CALL  TIME ( TIMEBUFF ) 

WRITE( 11,90)  TIMEBUFF 

90  FORMAT ( ///  '  STARTING  TIME  -  ' ,A8//) 


c 

c 

c 

c 

WRITE  (6,100) 

READ( 5 ,  * )  LAT , LON 

WRITE(  6,105) 

READ (5,1)  SEASON 

WRITE(  6,110) 

READ( 5 , * )  ZMAX , DZ 

NX  «  1 

NZ  «  Z MAX/D Z  +  1 
I F (  NZ  .GT.  MAX)  THEN 
NZ  -  MAX 
DZ  -  ZMAX/( NZ-1 ) 

END  IF 


RETURN 


1  FORMAT(A) 

100  FORMAT (  //'  ************<3CEAN  SIMULATION  MODEL******************* ' / 

1  '  VERSION  1.0  '/// 

2  '  Enter  latitude,  longitude  '/) 

105  FORMAT (//'  Enter  season  (WINTER, SPRING, SUMMER  OR  FALL)'//) 

110  FORMAT ( //  '  Enter  maximum  and  delta  depths  in  m,  '//) 


END 


*  Read  in  control  * 

*  data  * 


nnnnnnnonnnnonnnnnnnnnnnonnnnnnnnononnnnnnnnnn 


SUBROUTINE 


PROFILE  INPUT 


*  *  * * *4 ******4**4**4*4***44*****4***4**4*4**4*4**4*****4**4*4**4**4****4* 


PROGRAM 


PURPOSE 


PROFI LE_INPUT 

LOCATES  PROFILES  AT  LAT, LON, LATl , 
TEMPERATURE  AND  SALINITY  PROFILES 
LEVITUS  5°  DATABASE. 


LONl  AND 
AT  BOTH 


READS  IN  THE  * 
LOCATIONS  FROM* 


HISTORY 


10/25/88 


1.  Program  begun. 


AUTHOR ( S ) 


K.D.  Saunders  (NOARL) 


INPUT 


input  is  via  named  common 


OUTPUT 


SYS$OUTPUT 


COMMONS 


Diagnostic  information 

All  data  are  returned  via  named  common 


NOTES 


The  following  notes  are  from  the  comments  in  Wm.  Teague's  program  * 

_ _ * 

PROGRAM:  LEVFEB  * 

PURPOSE:  THIS  PROGRAM  READS  A  DIRECT  ACCESS  FILE  CREATED  BY  LEVRD  AND  * 

WRITES  AND  WRITES  THE  DATA  IN  VFEB  FORMAT.  THE  OUTPUT  GROUP  * 

CONSISTS  OF  30  DEPTH  LEVELS  WITH  DEPENDENT  VARIABLES  OF  * 

NO.  OF  TEMP  OBSERVATIONS,  MEAN  TEMP,  STANDARD  DEVIATION  OF  * 

TEMP,  NO.  OF  SAL  OBSERVATIONS,  MEAN  SAL,  AND  STANDARD  DEVIATION  * 
OF  SAL.  * 

_ * 

444*444**4*44*4*444**44**444*44***44444*4444444444*4**4444*444**4*44444444*44* 

IMPLICIT  NONE 
INCLUDE  ' MODELl . INC ' 

INTEGER*  4  ISHIF, 

1  I POSLOOP , 

2  ISF, 

3  IREC 


REAL*  4  D( 180 ) , 

ZLEV<  30) , 
T_TEMP( 300) , 
S  TEMP ( 300 ) , 
PT2), 

PAV, 


n  a  >  w>  oo  ,-4  cr> 


X_RAT I 0 , 
D_PR0FILES , 
E, 

RLAT, 

RLON, 

DIST, 

BVFRQ 


DATA  ZLEV/0,1 0,2 0,3 0,50, 7 5, 10 0,125 ,150,200,250,300,400,500, 

1  600,700,800,900,1000,1100,1200,1300,1400,1500, 

2  1750,2000,2500,3000,3500,4000/ 


Q* *  *  *  *  *******  ******  *  *  *  * 

C  OPEN  INPUT  FILE  * 

Q**  *******************  * 

OPEN ( UNIT-1 0, FILE-' MODELBASE$  sLEVITUS.DAT'  , 

&  ACCESS- 'DIRECT f , FORM- ' UNFORMATTED ' , STATUS- 'OLD' , 

&  ERR-9091,RECL-180, READONLY) 


C 

C 

C 

C 


C 

C 

C 


C 

c 

c 


c 

c 

c 


c 

c 

c 

c 


****************************************** 

*  WINTER  -  FEB,  MAR,  APR  -  * 

*  USE  MID  MARCH  FOR  TIME  IN  FDOC(l,l)  * 

IF  ( SEASON ( 1 : 2 ) . EQ . ' WI ' )  THEN 
ISHIF-0 

****************************************** 

*  SPRING  -  MAY,  JUN,  JUL  * 

ELSE  IF  ( SEASON ( 1 : 2 ) . EQ . ' SP ' )  THEN 
ISHIF-36 

*  SUMMER  -  AUG,  SEP,  OCT  * 

ELSE  IF  (SEASON(l:2) .EQ. 'SU' )  THEN 
ISHIF-72 

*  FALL  -  NOV,  DEC,  JAN  * 

ELSE  IF  (SEASON(l:2) .EQ. 'FA' )  THEN 
ISHIF-108 


ELSE 

****************************************** 

*  USE  SUMMER  IF  SEASON  NOT  CORRECTLY  * 

*  SPECIFIED  * 

****************************************** 

ISHIF  -  72 

END  IF 


IPOSLOOP  -  1 

RLAT  -  LAT 
RLON  -  LON 


I F ( RLON . LT . 0 ) RLON-RLON+  36  0 . 
RLAT-RLAT+90. 


C  *  CHECK  LAT  LON  VALUESW  * 


oonon  onnn  non 


IF  (ABS( RLON) .GE.  360  .  )  THEN 

WRITE( 6,*) 'LONGITUDE  NOT  BETWEEN  -180  AND  180  ' , RLON 
STOP 
END  IF 

IF  ( ABS( RLAT) .GT. 180 )  THEN 

WRITE ( 6 , * ) ' LATITUDE  NOT  BETWEEN  -90  AND  90  ' , RLAT 
STOP 
END  IF 


************************************* 

*  COMPUTE  DIRECT  ACCESS  RECORD  NO.S  * 
************************************* 

I-RLON/5.+1. 

J»RLAT/5.+l . 

IREC» ( 1-1 ) *144+J+ISHIF 


************************************* 

*  READ  DATA  RECORD  -  NUMOBS,  TEMP,  * 

*  SIGMA,  NUMOBS,  SAL,  SIGMA  * 

************************************* 


READ( 10' IREC, ERR-9092 )D 

K«0 

ISF-0 

WRITE( 11 , 130 ) 

DO  50  L=*l  ,90,3 
K=K+1 

BUF(1)«ZLEV(K) 

BUF(2)«D(L) 

BUF ( 3 ) =D ( L+l ) 

BUF ( 4 ) =D ( L+2 ) 

BUF ( 5 ) »D ( L+90 ) 

BUF( 6 )-D( L+91 ) 

BUF( 7 )-D( L+92 ) 

***************************** 

*  CHECK  FOR  0  OBSERVATIONS  * 

*  INSERT  MISSING  RECORD  FLAG* 

*  THEN  -999.0  * 

***************************** 

IF  ( BUF ( 2 ) . LE .0.1)  THEN 
BUF (  3)— 999.0 
BUF(4)«- 999.0 
END  IF 

IF  ( BUF ( 5 ) , LE .0.1)  THEN 
BUF(6)«- 999.0 
BUF(  7  )  —  999 . 0 
END  IF 

Z_IN { I POSLOOP , K )  -  BUF ( 1 ) 

TEMP_IN ( I POSLOOP , K )  -  BUF<3) 

SAL_IN(  I POSLOOP , K )  -  BUF(6) 

I F (  K.GT.l  .AND.  TEMP  IN( IPOSLOOP , K )  .LE. -998.0)  THEN 
TEMP_IN(IPOSLOOP,KT  -  TEMP_IN( IPOSLOOP, K-l ) 

END  IF 

I F (  K.GT.l  .AND.  SAL  IN( IPOSLOOP, K )  . LE .  -998.0) 

SAL_IN( IPOSLOOP, KT  -  SAL_IN( IPOSLOOP , K-l ) 

END  IF 


THEN 


non  nnonnn  nonnonnnooono  non 


WRITE(  11,140)  IPO  SLOOP  ,  K ,  TEMP_IN(  i  P 'Jo  LOOP ,  K  )  , 

1  SAL_IN ( IP0SL00P , K ) 

50  CONTINUE 

************************** 

*  CLOSE  THE  LEVI TUS  FILE  * 
************************** 

CLOSE ( UN IT* 10  ) 

************************************************************************ 

* 

INTERPOLATE  TEMPERATURE  AND  SALINITY  PROFILES  FROM  THE  INPUT  * 
PROFILES  ONTO  THE  SECTION  * 

* 

1.  First,  compute  the  distance  between  the  profiles  and  use  as  * 

input  distance.  * 

2.  Second,  fill  T,S  to  desired  depth  if  required  * 

3.  Interpolate  to  the  z-grid  * 

4.  Interpolate  to  the  x-grid  * 

5.  Compute  Brunt-Vai sala  frequencies  * 

* 

*  ,‘ w********************************************************************** 

DO  I  -  1 , NZ 

Z_OUT ( I )  -  ( 1-1 ) *DZ 
ZBV(I)  -  Z_OUT ( I ) 

END  DO 

*********************** 

*  Set  up  starting  * 

*  temperature  * 

*  and  salinity  * 

*  profiles  * 

*********************** 


DO  I  -  1,30 

T_TEMP ( I )  ~TEMP_IN ( 1,1) 

S_TEMP ( I )  -  SAL_IN( 1,1) 

END  DO 

CALL  INTRPL ( 6,30, ZLEV, T_TEMP , NZ , Z_OUT , DUMMY ) 

DO  I  -  1 , NZ 

TEMP (1,1)  *  DUMMY ( I ) 

END  DO 

CALL  INTRPL (6,30, ZLEV , S_TEMP , NZ , Z_OUT , DUMMY ) 

DO  I  -  1 , NZ 

SAL (1,1)  -  DUMMY ( I ) 

END  DO 

************************ 

*  Compute  BV  Freqs  * 

************************ 

K  -  1 

DO  I  «  1 , NZ-1 

T_TEMP ( 1 )  -  TEMP ( I , K ) 

T_TEMP ( 2 )  -  TEMP ( I + 1 , K ) 

S_TEMP ( 1 )  -  SAL ( I , K ) 

S  TEMP ( 2 )  -  SAL ( I +1 , K ) 

PTl)  -  Z_OUT ( I ) 

P ( 2 )  -  Z_OUT( 1+1 ) 

BVF ( I , K )  -  BVFRQ ( S_TEMP , T_TEMP , P , 2 , PAV, E ) 

END  DO 

BVF ( NZ , K )  -  BVF ( NZ-1 , K ) 


999  RETURN 

9091  STOP  'ERROR  IN  OPENING  LEVITUS  FILE' 

9092  STOP  'ERROR  IN  READING  LEVITUS  FILE' 

100  FORMAT (  '  PROFILE  ',14,'  X  -  ',F10.3// 

1  '  Z  T  S  BV  '//) 

110  FORMAT {  4F12.3) 

120  FORMAT (  '**********  INITIAL  INTERPOLATE  PROFILES  TEMP , SAL , BVF ' , 

1  '  ARRAYS  **★***★******»//) 

130  FORMAT ( // '  INPUT  TEMPERATURE  AND  SALINITY  PROFILES  '//) 

140  FORMAT (  IX, 214 , 2F12 . 3  ) 

END 


nonooonononnoooonnonnonononnn 


SUBROUTINE 


INT  WAVE  SIMULATION 


PROGRAM 


INT  WAVE  SIMULATION 


PURPOSE 


Does  most  of  the  calculations  for  MODEL1 .  It  is  based 
on  the  Garrett-Munk  internal  wave  model. 


HISTORY 


10/26/88 


Coding  begun 


AUTHOR ( S ) 


K.D.  Saunders  (NOARL) 


INPUT 


All  interprocess  communication  is  via  named  common. 


OUTPUT 


All  outr'j.  is  done  in  subroutine  calls. 


Notes 


Subroutines  called: 


DISPLACEMENTS 


IMPLICIT  NONE 
INCLUDE  ' MODELl . INC ' 


LOGICAL*! 


BV  CHANGED  /  .TRUE.  / 


INTEGER*  4 


I DI R , NBV , NNZ , I IX 


REAL *4 


ZT ( MAX ) , BVT { MAX ) 


NMODES 

NF 

NBV 

NNZ 


DO  K  -  1 , NBV 

BVT(K)  -  BVF ( K , IX ) 
ZT ( K )  -  ZBV(K) 

END  DO 


NMODES 

NF 

NBV 

NNZ 

NX 


oonooooo 


T  -  0 

XMAX  -  0 

IDIR  -  0 

TYPE  *,  '  LAT,AZIMUTH' , LAT, AZIMUTH 

*  This  is  the  same  call  * 

*  as  in  Rubenstein ' s ,  * 

*  except  for  the  IX  * 

*  parameter.  The  * 

*  displacements  are  * 

*  computed  at  each  range* 


100 

110 

120 


CALL  DI S PLACE ( ZD , NNZ ,  NX , XMAX , T , 

1  AZIMUTH, IDIR, NF,NMODES , 

2  LAT , NBV, ZT , BVT , IX , 

3  MAX , MAX ) 


RETURN 

FORMAT (  '  IX , NX , NZ , NBV, NF , NMODES  -',7110/ 

1  '  XMAX  -  ' , G1 5 . 4 , '  T  -  ',G15.4, 

2  '  LAT  -  ' , G15 . 4//) 

FORMAT (  '  *  *  *RETURN  FROM  DISPLACE***') 

FORMAT (  '  ********  OCEAN  SIMULATION  MODEL  VERSION 


1  '  NT  ',15/ 

2  '  NX  ',15/ 

3  '  NZ  ',15/ 


4 

t 

DT 

' , G20 . 5/ 

5 

f 

DX 

' , G20 . 5/ 

6 

r 

DZ 

' , G20 . 5/ 

7 

f 

TO 

' , G20 . 5/ 

8 

t 

LAT 

' , G20 . 5/ 

9 

r 

LON 

' , G20 . 5/ 

A 

r 

AZ 

' , G20 . 5//) 

1.0  '// 


END 


nonnoonoonoonnnonnonnooonnnoonnnoonoonnoono 


SUBROUTINE  DISPLACE  (  Z,  NZ ,  NX,  TOTX,  T,  ANGLE,  IDIR, 

1  NF,  NMODES,  LAT,  NBV ,  ZT,  BVT  ,IX, 

2  NBVMAX , NXMAX ) 

* 

PROGRAM  DISPLACE  * 

* 

PURPOSE:  * 

* 

Calculate  random  vertical  displacements  (correlated  in  time)  due  to  * 

internal  waves.  A  Garrett-Munk  type  of  spectrum  is  used  to  generate  the  * 
proper  energy  levels.  The  displacements  are  packed  into  array  Z(NZ,NX),  * 
which  covers  a  vertical  plane.  * 

* 


Input  Parameters 


NX 

TOTX 

T 

ANGLE 

IDIR 


NF 

NMODES 

LAT 

NBV 

ZT 


Number  of  points  in  the  vertical  used  in  * 
calculating  modes  (Integer*4)  * 
Number  of  points  in  the  horizontal  (Integer*4)  * 
Total  distance  in  x-direction,  in  meters  (Real*4)  * 
Time  in  seconds  (Real*4)  * 
Azimuth  angle  of  the  vertical  plane,  in  degrees  * 
Flag  for  directionality  of  internal  waves  * 

*  0  Isotropic  * 

*  1  Along-range  propagation  ( ky  »  0 )  * 
■  2  Cross-range  propagation  ( kx  -  0)  * 
Number  of  frequencies  in  expansion  (Integer*4)  * 
Number  of  modes  in  expansion  (Integer*4)  * 
Latitude,  in  degrees  (Real*4)  * 
Number  of  points  in  BV  profile,  and  in  output  array  Z ( IntegerM ) * 
Depths  of  BV  frequencies,  and  of  output  displacements  Z,  * 
in  meters  (Real*4  array  of  length  NBV)  * 
Set  of  BV  frequencies,  in  cph  (Real*4  array  of  length  NBV)  * 


Output  parameter  * 

★ 

Z  Array  of  vertical  displacements,  in  meters  (Real*4  2-D  array  * 

of  Size  NBVMAX  x  NXMAX  * 

★ 

Note:  The  BV-frequency  array  BVT  is  of  length  NBV,  which  is  interpolated  * 
onto  a  regularly  spaced  grid  of  length  NZ .  The  output  array  WM  from  * 

subroutine  MODESUB  is  interpolated  back  into  a  grid  of  length  NBV.  * 

* 

MAX  is  the  maximum  number  of  depth  points  allowed  in  MODESUB  calculations* 


PARAMETER  (  MAX  -  5000,  MODEMAX  -  20,  NFMAX  -  500) 

REAL  Z ( NBVMAX , NXMAX ) ,  BVT (NBVMAX),  ZT( NBVMAX),  LAT 
REAL  FF( 2 ) , ZF ( 2  ) 

REAL  F ( NFMAX )  ,  FR(NFMAX),  ZDEP(MAX),  WMINT (  MAX ) 

REAL  K ( 0 : MODEMAX ) ,  WM ( MAX , 0 : MODEMAX ), w( max ) 

REAL  KX,  KY 

REAL  COST( 0: MODEMAX, NFMAX ) ,  S INT ( 0 : MODEMAX , NFMAX ) 
REAL*  4  EPS I  LON, KK( NFMAX, 0: MODEMAX) , XK ( NFMAX ) , XF ( NFMAX ) 

COMPLEX  A( 0 : MODEMAX, NFMAX ) ,  11,  FACTOR 

DATA  JSTAR  /  1  / 

INTEGER*  4  ISEED0  /191531459/, 

ISEED, 


1 


non  non 


IX 


C  * 
C  FI  and  BVMAX  are  .inertial  frequency  and  maximum  BV  frequency,  in  cph.* 
C  * 
C  * 

C  INITIALIZE  VARIABLES  ON  EACH  PASS  THROUGH  THIS  ROUTINE  * 


I  SEED 

II 
PI 

DEGRAD 

JSTAR 

FACTOR 

KX 

KY 


ISEEDO 

(0.,  1.) 

4 . *ATAN ( 1 . ) 
PI/180  . 

1 

(0,0) 

0 

0 


FI  *  S IN ( DEGRAD*LAT ) /I 2 . 0 


TYPE  *,  '  ENTER  NF' 

ACCEPT  * , NF 

TYPE  *,  '  ENTER  NMODES' 

ACCEPT  *,  NMODES 


DF  -  ( 4 . 0-FI )/nf 
DO  I  FREQ  -  1 , NF 

F ( I  FREQ )  »  I FREQ*DF  +  FI 

END  DO 


*  Initialize  Z  * 

★★★★★★★★★★★★★★★★★A******* 


*  added  10/27/88  -  kds  * 

★★★★★★★★★★★★★★★★★★★★A**** 

J  -  IX 

DO  160  1*1,  NBVMAX 
Z(I,J)  =  0.0 
160  CONTINUE 


C  Note:  Ordinarily,  both  F  and  DF  should  both  be  in  units  of  rad/sec.  * 
C  Since  DF  is  being  divided  by  F,  and  they  are  both  in  the  same  units  of  * 
C  cph,  their  units  do  not  need  to  be  converted  (except  in  the  exponential)  * 


IPRINT  *  0 

EPSILON  -  0.001 

DO  I  FREQ  -  NF ,1,-1 

DO  M  -  0 , MODEMAX 
K  (  M  )  -  0 
END  DO 

DO  M  -  1 , MAX 

ZDEP(M)  -  0.0 
WMINT(M)-  0.0 


non  oonoo  non 


DO  MM  -  0 , 110DEMAX 
WM ( M , MM )  -  0.0 
END  DO 
END  DO 

CALL  MODESUB  (  NMODES ,  F( IFREQ),  NBV ,  ZT,  BVT ,  NZ ,  LAT, 

1  EPSILON, 

2  IPRINT  ,  k,  zdep,  wm  ) 

WRITE (*,*) 'ifreq=' ,ifreq,F( IFREQ) ,  '  K  -  ' 

WRITE (*,*)( k ( m ) , m*0 , nmodes ) 

WRITE( 11 , 100 ) F( 1 )  ,  ( K ( M ) , M*0 , 3  ) 

DO  H  «  0, NMODES 

KK ( I  FREQ , M )  *  1 0 0 0  * K ( M ) /( 2 . *pi ) 

END  DO 

I F (  IFREQ  .EQ.  1)  THEN 
DO  I  *  1 , NZ 

WRITE (11,110)  ZDEP ( I ) ,  ( wm( i , m ) , m-0 , 3 ) 

END  DO 
END  IF 


END  DO 


*  END  IFREQ  LOOP  * 


PLOT  OUTPUT  HERE  * 

* 


CALL  COMPRS 
CALL  SETDEV (8,9) 

************************************* 

*  SET  UP  PLOT  AND  PLOT  THE  RESULTS  * 
************************************* 


CALL  PAGE (11. 0,8. 5) 

CALL  PHYSOR ( 1 . 0 , 2 . 0  ) 

CALL  AREA2D ( 4 . 0 , 5 . 0  ) 

CALL  SERIF 

CALL  SHDCHR{0. 0,1,  .01,1) 

CALL  HEIGHT( .175) 

CALL  HEADIN( %REF( ' INTERNAL  WAVE  MODES$ '  ) , 100 , 1 . 25 , 1  ) 
CALL  XNAME( %REF( 'Horizontal  Wavenumber  -  cpkm$'),100) 
CALL  YNAME( %REF( ' Frequency  -  cph$'),100) 

CALL  GRAF (0.0, 1.0, 4. 0,0. 0,1. 0,4.0) 

CALL  FRAME 
CALL  GRACE (0.0) 

DO  M  -  0, NMODES 
NNF  -  0 
DO  I  -  1 , NF 

I F ( KK ( I , M )  .GT.  1.0E-4  ) THEN 
NNF  -  NNF  +  1 
XK(NNF)  -  KK ( I , M ) 

XF(NNF)  -  F ( I ) 

END  IF 


IF  (  NNF.GE.  2)  THEN 

XKNEXT  -  XK(NNF-l) 


1 

+ 

(XF(NNF)-XF(Ntn  -1  )  )* 

2 

( XK ( NNF-1 )  -XK  ( NNF- 2 ) )/ 

3 

( XF  ( NNF-1 ) -XF ( NNF- 2 ) ) 

END 

IF 

IF( 

NNF.GT.  2  .AND. 

1 

XK(NNF)  .LE.  XK ( NNF-1 ) 
NNF  -  NNF  -1 

END 

IF 

)  THEN 


C 

C 

c 


c 

c 

c 


********************** 
*  END  NFREQ  LOOP,  NF  * 


END  DO 

CALL  CURVE ( XK ( 1 ) , XF ( 1 ) , NNF , 0 ) 


★★★★★★★★★★★A********* 

*  END  MODES  LOOP  * 


END  DO 


CALL  ENDGR(l) 

FF ( 1 )  =  F ( 1  ) 

FF ( 2 )  -  F ( 1  ) 

ZF(  1  )  -  0.0 
ZF ( 2 )  -  ZT(NBV) 

CALL  PHYSOR( 6 . 0 , 2 . 0 ) 

CALL  AREA2D ( 4 . 0 , 5 . 0 ) 

CALL  SERIF 

CALL  SHDCHR( 0.0,1, .01,1) 

CALL  HEIGHT ( .175) 

CALL  HEADIN( %REF( 'Brunt-Vaisala  Frequency  Prof i le$ ' ) , 100 , 1 . 25 , 1 ) 
CALL  XNAME ( %REF ( 'Frequency$' ) ,100) 

CALL  YNAME( %REF( 'Depth  -  m$'),100) 

CALL  GRAF (0. 0,5.0, 15. 0,ZT( NBV ) ,-500.0,0.0) 

CALL  FRAME 

CALL  CURVE (BVT,ZT, NBV, 0) 

CALL  DASH 

CALL  CURVE (FF,ZF, 2,0) 

CALL  ENDGR ( 2 ) 

CALL  ENDPL(O) 

CALL  DONEPL 


RETURN 

100  FORMAT ( ///'  FIRST  FOUR  MODES  '/ 

1  '  FREQUENCY  -  ',F15.5// 

2  12X, 'K(l) ' ,11X, 'K(2)' ,11X, 'K( 3) ' , 11X, '  K  (  4  ) '/ 

3  6X, 4F15 . 5///  '  AMPLITUDES  '// 

4  5X, 'Z' ,7X, '1' ,14X, '2' ,14X, '3' ,14X, '4'/) 


110 


FORMAT (  IX, F6 . 1 , 4F15 . 5 ) 
END 


nonnonoonoononnnnnnonnonnonnooonononnnoonononoooonooononnnnnno 


SUBROUTINE  MODESUB  (  NMODES,  F,  NBV ,  ZT,  BVT ,  NZ ,  LAT,  EPSLON, 

1  IPRINT,  K,  Z,  WM  ) 

***************************************************************************** 

* 

This  routine  computes  the  internal  wave  vertical  modes  and  horizontal  * 
wavenumbers  for  a  prescribed  Vaisala  frequency  profile,  at  a  given  set  * 
of  frequencies.  The  ODE  which  is  solved  is  * 

* 

( N( z ) **2  -  F**2  )  * 

w"  +  [ k* *2  ]  * - w  -  0  ,  * 

(  F**2  -  Fi**2)  * 

* 

where  w  is  vertical  velocity,  N(z)  is  Brunt-Vaisala  frequency,  k  is  * 

wavenumber,  F  is  wave  frequency,  Fi  is  inertial  frequency,  and  * 

z  is  depth.  .  * 

* 

The  vertical  modes  W(z)  generated  by  this  code  are  in  units  of  m/sec,  and  * 
the  wavenumbers  k**2  are  in  units  of  ( radians/m) **2 .  The  normalization  * 
of  W(z)  is  such  that  the  integral  from  bottom  to  surface  of  Potential  +  * 
Kinetic  Energy  is  given  by  * 

* 

Int [ PE+KE ] dz  -  Int[W( z ) * {N( z ) **2  -  Fi**2}/{F**2  -  Fi**2}]dz  * 

«  No**2  *  b**3  ,  * 

* 

where  b  »  1300  meters,  and  No  is  the  scale  Vaisala  frequency  -  * 

3  cph  *  (2*pi/3600)  ( rad/cycle )*( hr/sec )  *  5.24*10-4  rad/sec.  * 

* 

To  produce  the  nondimensional  normal  modes  Z(z)  found  in  Garrett  and  * 

Munk  (1972),  one  must  divide  W(z)  by  b*F,  where  b  «  1300  m,  and  * 

F  -  frequency  in  radians  per  second.  * 

* 

***************************************************************************** 
David  Rubenstein,  Science  Applications  International  Corp. ,  Nov.  1987  * 

Version  for  Lahey  77  Fortran,  IBM-PC  * 

***************************************************************************** 

* 

Input  Parameters  * 

* 

NMODES  Number  of  modes  desired  (Integer*4)  * 

F  Wave  Frequency,  in  cph  (Real*4)  * 

NBV  Number  of  points  in  BV  profile  (Integer*4)  * 

ZT  Depths  of  BV  frequencies,  in  meters  (Real*4  array  of  length  NBV)  * 

BVT  Set  of  BV  frequencies,  in  cph  (Real*4  array  of  length  NBV)  * 

NZ  Preliminary  estimate  for  number  of  points  required  in  * 

vertical  modes  (Integer*4)  * 

LAT  Latitude,  in  degrees  (Real*4)  * 

EPSLON  Relative  accuracy  required  for  determination  of  K**2  (Real*4)  * 

Recommended  value:  0.001  * 

IPRINT  Print  parameter.  Set  -  0  for  no  diagnostics.  * 

* 

Output  parameters  * 

* 

NZ  Actual  number  of  points  in  computed  vertical  modes  (Integer*4)  * 

K  Wavenumber,  in  Radians/meter  (Real*4  array  of  length  NMODES)  * 

Z  Depths,  in  meters,  corresponding  to  vertical  velocity  modes  * 

(Real*4  array  of  size  NZ )  * 

WM  Vertical  velocity  modes,  in  m/sec  (Real*4  2-D  array  of  size  * 

NZ  X  NMODES)  * 

* 

Restrictions:  Maximum  value  for  NZ  is  MAX,  and  maximum  value  for  NMODES  * 
is  MODEMAX,  both  of  which  are  set  in  the  parameter  statement.  * 

* 

Suggestion  on  usage:  Call  this  subroutine  (MODESUB)  once  for  each  frequency* 
desired,  but  start  with  the  highest  frequency  and  work  downward.  This  * 


n  o  o  n  n 


C  subroutine  tests  for  sufficient  resolution,  and  the  constraint  is  greatest  * 
C  at  high  frequencies.  * 
C  * 


PARAMETER  (  MAX  -  5000,  MODEMAX  -  20  ) 

REAL  BV ( MAX ) ,  W(MAX),  F,  K2 ( 0 : MODEMAX ) ,  LAT,  G ( MAX ) 

REAL  Z ( MAX ) ,  BVT(NBV),  ZT(NBV),  K20LD ,  K2NEW 
REAL  K2MAX,  K2MIN,  WM ( MAX , 0 : MODEMAX ) ,  K ( 0 : MODEMAX ) 

DATA  BDEP/1300 . 0/,  NRES/5/ 

K20LD  -  0 
K2NEW  *  0 
K2MAX  -  0 
K2MIN  -  0 
BDEP  -  1300.0 
NRES  -  5 

DEPTH  -  ZT(NBV) 

PI  -  4 . *ATAN ( 1 . ) 

DEGRAD  -  PI/180. 

FI  -  SIN(DEGRAD*LAT)/12.0 

IF  (  NMODES*NRES  . GT .  NZ  )  THEN 
NZ  =  NRES*NMODES 
WRITE( * , 25 )  NZ 

25  FORMAT ( '  NZ  has  been  adjusted  to  -  ',i5) 

ENDIF 

28  CONTINUE 

IF  (  NZ  .GT.  MAX  )  THEN 
WRITE ( * , 30 )nz ,max 

30  FORMAT! '  NZ  -  ',i5,'  is  >  MAX  -  ',i4, '.',/, 

1  '  Decrease  NMODES  or  increase  MAX.  Program  aborting.') 

STOP 

ENDIF 

CALL  INTERP  (  NBV,  ZT,  BVT ,  NZ ,  DEPTH,  Z ,  BV  ) 

DZ  -  DEPTH/! NZ-1) 

****************************************** 

*  Test  for  resolution  between  turning  * 

*  points.  NRES  is  the  minimum  number  of  * 

*  vertical  sampling  intervals  per  mode  * 
****************************************** 

DO  60  J  -  1,  NZ 

G(J)  -  ( BV ( J  )  **2  -  F**2  )  /  ( F  *  *  2  -  FI**2) 

60  CONTINUE 

CALL  TURN!  G,  NZ ,  JA,  JB ,  JM  ) 

IF  (  NMODES*NRES  .GT.  JB-JA  )  THEN 

TYPE  *,  ' JA, JB' , JA, JB 
TYPE  * ,  ' F  -  ' , F 
TYPE  *,  'FI-  ' , FI 

WRITE!*, 70)  NMODES,  NRES,  JB-JA 
70  FORMAT!'  NMODES  -  ',i3,'  *  ',i3,'  >  JB-JA  -  ',i3,/, 

1  '  Region  between  turning  points  insufficiently  resolved.') 


nn  non  non  non 


NZ  -  NZ  *  1.25 
WRITE{ *  ,  25  )  NZ 

GO  TO  28 
ENDIF 

DO  80  J  -  1,  NZ 

G{ J )  -  ( BV ( J ) * *2  -  F**2)  /  (F**2  -  FI**2 ) 

80  CONTINUE 

CALL  TURN (  G,  NZ ,  JA,  JB,  JM  ) 

CALL  AVGINT  (  G,  NZ ,  JA,  JB,  DZ ,  GAVG  ) 

AFACTOR  -  ( PI/GAVG) **2 
II  **  1 
N  -  NZ 

****************************** 

*  Loop  through  modes  * 

****************************** 

DO  400  M  «  0,  NMODES 

****************************** 

*  First  guess  for  k**2  * 

****************************** 

K20LD  «  AFACTOR* (M+l. 5  )**2 

I F ( I PRINT . GE . 1 ) WRITE ( *,*) 'Start  iteration:  k2old  -  ',k2old 
K2MAX  -  K2OLD*40 . 0 
K2MIN  -  K2OLD/40 . 0 

IF  (  M  .GT.  0  )  K2MIN  -  K2(M-1) 

ITERATE  =  0 
NUMBER  -  0 
K2NEW  -  K2MIN 

*************************** 

*  Top  of  Iteration  loop  * 
*************************** 

100  CONTINUE 

IF ( IPRINT.GE.l ) WRITE ( *,*) 

IF  (  ( K2MAX-K2MIN)/K2MAX  .LT.  EPSLON  )  THEN 

I F ( I  PRINT , GE . 1 )  WRITE( *,*) 'Converged:  k2min , k2max- ' , 

1  k2min,k2max 

GO  TO  115 
ENDIF 

ITERATE  -  ITERATE  +  1 

IF  (  ITERATE  .GT.  200)  THEN 
K(M)  -  0.0 
GOTO  400 

END  IF 

CALL  NUMEROV  (  M,  II,  N,  JA,  JB,  JM,  G,  W,  DZ , 

1  IPRINT,  ICOUNT,  ICROSS,  K20LD ,  K2NEW  ) 

IF  (  IPRINT.GE.l  .OR.  MOD( ITERATE, 20 ). EQ. 0  )  THEN 

WRITE (*,*)' ITERATE , M , ICOUNT , K20LD , K2NEW, K2MIN , K2MAX  -  ' 
WRITE ( * , 110 ) ITERATE , M , ICOUNT , K20LD , K2NEW , K2MIN , K2MAX 
110  FORMAT ( 3I4,2D15.4,5X,2D14.4) 

ENDIF 


n  n  n  n  o  n  o 


IF  (  ICOUNT  .NE.  M  )  THKn 
IF  (  ICOUNT  .LT.  M  )  THEN 

IF  (  ICROSS  .EQ.  0  )  THEN 

K2MIN  -  AMAXl (K2MIN,K20LD) 

ELSE 

K2MIN  -  AMAXl {K2MIN,0.5*(K2MIN+K2OLD) ) 
ENDIF 
ELSE 

K2MAX  -  AMINl ( K2MAX , K20LD ) 

ENDIF 

IF  (  ICROSS  .EQ.  1  )  THEN 
NUMBER  -  NUMBER  +  1 
DELTAl  -  0 . 5 * ( K2MAX+K2MIN )  -  K20LD 
DELTA2  -  K20LD*( (2.0*M+1. )/( 2 . 0*ICOUNT+1 )  -  1.0) 
IF  (  ABS( DELTAl)  .GT.  2 . *ABS ( DELTA2 )  )  THEN 

K20LD  «  K20LD  +  DELTA2 
ELSE 

K20LD  -  K20LD  +  DELTAl 

ENDIF 
GO  TO  100 
ENDIF 

IF  (  ICOUNT  .LT.  M  )  THEN 

K20LD  -  0 . 5* ( K2MAX+K20LD ) 

ELSE 

K20LD  -  0. 5MK2MIN+K20LD) 

ENDIF 

GO  TO  100 


********************* 

*  END  IF,  ICOUNT  * 
********************* 

ENDIF 

IF  (  ABS( ( K20LD-K2NEW ) /K2NEW )  .GT.  EPSLON  )  THEN 
IF  (  ICROSS  .EQ.  1  )  GO  TO  100 

IF  (  K2NEW  .GT.  K20LD  )  THEN 
K2MIN  -  K20LD 
ELSE 

K2MAX  -  K20LD 

ENDIF 

K20LD  -  K2NEW 
GO  TO  100 
ENDIF 


IF  (  IPRINT  .GE.  1  )  THEN 
WRITE ( * , *  ) 

WRITE( *,*)' Converged :  k2old,  k2new- ' , k2old , k2new 
ENDIF 


*  Pad  with  zeros  if  bottom  or  top  were  * 

*  brought  in  * 

115  CONTINUE 

IF  (  II  .GT.  1  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE (*,*)'  ZERO-Pad:  il  -  ',il 
DO  135  I  -  1,  11-1 
W( I )  -  0. 

135  CONTINUE 

ENDIF 


non  o  n  o 


non  non  ono  noon 


SUBROUTINE  TURN  (  G,  NZ ,  JA,  Ml,  JM  ) 


*  Find  maximum  * 
******************** 

JM  -  1 
GMAX  -  G(l) 

DO  10  I  -  2,  NZ 

IF  (  G( I )  .GT.  GMAX  )  THEN 
JM  -  I 
GMAX  -  G(I) 

ENDIF 
10  CONTINUE 


20 


IF  (  JM  .LE.  2  )  THEN 

IF  (  G ( I ) . GT . 0 . 2  5  *  GMAX  )  THEN 
JM  -  3 
ELSE 

WRITE (*,*)'***  peak  too  close  to  surface.  Increase  NZ.***' 
WRITE (*,*)' jm  -  ',jm,'  gmax- ' , gmax , '  g:' 

WRITE (*,*) (G( I) , 1-1 , NZ  ) 

STOP  10 
ENDIF 

ENDIF 


*  Find  upper  turning  point  * 


DO  20  I  -  JM,  1,  -1 

IF  (  G( I )  .GT.  0.  )  JA-  I 

CONTINUE 


DO  30  I  -  JM,  NZ 

IF  (  G ( I )  .GT.  0 .  )  JB  -  I 

30  CONTINUE 


Find  lower  turning  point  * 


RETURN 

END 


noon  nnno 


subroutine  avgint  (  g,  nz,  ja,  jb,  dz,  gavg  ) 


* 


subroutine  avgint  * 

* 


*  Integrate  g(z)  from  index  j  -  ja  * 

*  to  jb,  and  get  average  * 


REAL  G(NZ) 

GAVG  -  0. 

DO  20  J  «  JA,  JB 

GAVG  =  GAVG  +  SQRT ( ABS ( G ( J ) ) ) 
20  CONTINUE 

GAVG  -  GAVG*DZ 

RETURN 

END 


noon  nonon  non  nonno 


SUBROUTINE  NUMEROV  (M,  11,  N,  JA,  JB ,  JM,  G,  W,  DZ , 

1  IPRINT,  ICOUNT,  ICROSS ,  K20LD ,  K2NEW ) 


* 


SUBROUTINE  NUMEROV  * 

* 


PARAMETER  (  MAX  -  5000  ) 

REAL  G  (  N )  ,  W(N),  K20LD ,  K2NEW 
REAL *8  T ( MAX ) ,  PHIP(MAX),  PHIM(MAX) 

REAL*8  S,  FACT,  PHI2,  AlP,  A2P ,  AIM,  A2M,  BlP,  B2P,  BlM,  B2M 
REAL* 8  PHIPPR,  PHIMPR 

DATA  S/1./ 


10  CONTINUE 


Initialize  end  points 


PHIM(Il)  =  0. 
PHIM( I 1+1 )  -  S*DZ 
PHIP(N)  -  0. 


IF  (  MOD ( M , 2 )  .EQ.  0  )  THEN 
PHIP(N-l)  -  S *DZ 
ELSE 

PHIP(N-l)  -  -S*DZ 
ENDIF 


ICROSS  -  0 
ICOUNT  -  0 

FACTOR  -  ( DZ**2 ) *K20LD/12 . 


*  Icross  is  a  flag,  which  is  set  -  1  * 

*  if  there  is  a  zero-crossing  at  the  * 

*  match  point,  but  no  sign  match  * 


DO  20  I  »  II,  N 

T ( I )  -  -FACTOR  *  G(I) 
20  CONTINUE 


JBOT  -11+2 


1 


DO  40  J  -  JBOT,  JM  +  2 

FHIM(J)  -  (  (2.  +  10.*T( J-l) )*PHIM( J-l )  + 

( T{ J-2 )  -  1. )*PHIM( J-2)  )  /  (l.-T(J)) 

I F (  J.LE.JM  .AND.  PHIM( J-l ) *PHIM( J ) . LE . 0 .  ) ICOUNT  -I COUNT+1 


*  Bring  in  top  if  exponential  growth  * 

*  is  sufficiently  strong  * 


ARG  -  ( ABS ( PHIM ( J ) ) +ABS ( PHIM ( J-l ) ) )  / 

1  ( ABS ( PHIM ( I 1+1 ) ) +ABS ( PHIM( 11+2 )) ) 

IE  (  ARG  .GT.  1.E12  )  THEN 
IBOT  -  II  +  1 
DO  30  I  -  J,  IBOT,  -1 

ARG  -  ( ABS ( PHIM( J ) ) +ABS (PHIM(J-l) ) )  / 
(  ABS ( PHIM ( I ) )+AHS( PHIM( 1-1 ) ) ) 


1 


non  non  nnnn  non 


IF  (  ARG  .GT.  1.E6  )  THEN 
II  -  I 
GO  TO  10 
ENDIF 

30  CONTINUE 

ENDIF 

IF  (  ICOUNT  .GT.  M  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE* *,*)' ICOUNT  >  M  IN  PHIM' 

GO  TO  600 
ENDIF 

****************** 

*  END  LOOP,  JBOT  * 

40  CONTINUE 

JTOP  *  N  -  2 

DO  60  J  =  JTOP,  JM-2,  -1 

PHIP(J)  *  (  (2.  +  10.*T( J  +  l) )*PHIP( J+l)  + 

1  ( T ( J+2 )  -  1. )*PHIP( J+2)  )  /  (l.-T(J)) 

I F (  J.GE.JM  .AND.  PHI P { J+l ) * PHI P ( J ) . LE . 0 .  )IC0UNT  -  ICOUNT+1 

*  Bring  in  bottom  if  exponential  growth  is  * 

*  sufficiently  strong  * 

******************************************** 

ARG  -  ( ABS ( PHIP ( J ) ) +ABS ( PHIP ( J+l ) ) )  / 

( ABS ( PHI P ( N-l ) ) +ABS ( PHIP(N-2 ) ) ) 

IF  (  ARG  .GT.  1.E12  )  THEN 
ITOP  -N-l 
DO  50  I  -  J,  ITOP 

ARG  -  ( ABS ( PHIP ( J ) ) +ABS ( PHIP ( J+l )  )  )  / 

( ABS ( PHIP ( I ) ) +ABS ( PHIP ( 1+1 ) ) ) 

IF  (  ARG  .GT.  1.E6  )  THEN 
N  -  I 
GO  TO  10 
ENDIF 
CONTINUE 
ENDIF 

IF  (  ICOUNT  .GT.  M  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE( *,*)' ICOUNT  >  M  IN  PHIP' 

GO  TO  600 
ENDIF 

*  END  LOOP,  JTOP  * 

60  CONTINUE 


*  Does  zero-crossing  occur  at  match-point?  * 

IF  (  PHIP( JM) *PHIM( JM)  .LE.  0.0  )  THEN 
ICROSS  -  1 
ICOUNT  -  ICOUNT  +  1 

IF  (  IPRINT  .GE.  1  )  WRITE* *,*)' zero-crossing  at  j-jm-', 

1  jm, '  icount-' , icount 

IF  (  ICOUNT  .NE.  M  )  THEN 

IF  (  IPRINT  .GE.  1  )  WRITE( *,*)' icount  <>  m  at  match  point' 

GO  TO  600 


1 


1 


50 


ENDIF 

C 

C 

c 


*  Look  for  sign-match  * 


1 

2 

3 


1 


C 

C 

c 


IF  (  PHIP( JM-1 ) *PHIM( JM) .GT.0.0  .OR. 

PHI P ( JM-2 ) *PHIM ( JM ) .GT.0.0  .OR. 

PHIP(JM)*PHIM( JM+1 ) . GT .0.0  .OR. 

PHIP< JM) *PHIM( JM+2 ) .GT. 0 . 0  )  THEN 
JMl  »  JM  +  0 . 5* ( JB- JA )/( M+2 . ) 

JM2  -  JM  -  0.5*( JB-JA)/(M+2. ) 

IF  (  JMl  .GT.  JA  .AND.  JMl  .LT.  JB  )  THEN 
JM  -  JMl 
ELSE 

IF  (  JM2.GT.JA  .AND.  JM2.LT.JB  )  THEN 
JM  -  JM2 
ELSE 

JM  -  0 . 5 * ( JM  +  JB) 

ENDIF 

ENDIF 

IF  (  IPRINT  .GE.  1  )  WRITE ( * , * ) 

'Sign  match  found.  New  jm«',jm 

GO  TO  700 
ELSE 

I COUNT  -  M  -  1 
GO  TO  600 

********************** 

*  END  IF,  SIGN  MATCH  * 
********************** 

ENDIF 


C 

C 

C 

ENDIF 


*  END  IF,  ZERO-CROSSING  * 


IF  (  ICOUNT  .NE.  M  )  GO  TO  600 

C  ************************** 

C  *  Adjust  phi  by  a  factor  * 

C  ************************** 

FACT  -  PHI P ( JM ) /PHIM ( JM ) 

IF  (  FACT  .GT.  1.  )  THEN 

DO  70  J  -  JM-2,  N 

PHIP(J)  -  PHIP ( J )/FACT 
70  CONTINUE 

ELSE 

DO  80  J  -  2,  JM+2 

PHIM(J)  -  FACT* PHIM ( J ) 

80  CONTINUE 

ENDIF 

********************** 

*  Integrate  phi**2  * 
********************** 


DO  100  J  -  2,  JM 

PHI2  -  PHI 2  +  G(J-1)*PHIM(J-1) **2+G( J)*PHIM(J)**2 
100  CONTINUE 


non  non  non 


DO  110  J  -  JM+1,  N 

PHI 2  -  PHI 2  +  G(J-1)*PH1P(J-1)**2+G(J)*PHIP(J)**2 
110  CONTINUE 


PHI2  *  0 . 5*DZ*PHI2 


Compute  phip'  and  phim'  * 


A1P  *=  0.5*(PHIP(  JM+1)-PHIP(  JM-1)  ) 
A2P  -  0.5*(PHIP( JM+2)-PHIP( JM-2)  ) 
AIM  =  0 . 5 *  (  PHI M ( JM+1 ) — PHI M ( JM— 1 ) ) 
A2M  -  0 . 5* ( PHIM( JM+2 )-PHIM( JM-2 ) ) 


BlP  =  T( JM+1 ) *PHIP( JM+1 ) 
B2P  -  T( JM+2 ) *PHIP( JM+2 ) 
BlM  -  T( JM+1)*PHIM( JM+1) 
E2M  =  T( JM+2)*PH1M( JM+2) 

PHIPPR  -  ( 16 ./( 21 . *DZ ) ) * 
1  -  (17./40. )*B2P 

PHIMPR  *  ( 16 ./( 21 . *DZ ) ) * 
1  -  (17. /40. )*B2M 

DO  120  J  =  1,  JM 
W(J)  *  PHIM ( J ) 

120  CONTINUE 

DO  140  J  «  JM+1,  N 
W(J)  -  PHIP(J) 

140  CONTINUE 


-  T( JM-1)*PHIP( JM-1) 

-  T(JM-2 )*PHIP( JM-2 ) 

-  T( JM-1)*PHIM( JM-1) 

-  T( JM-2 ) *PHIM( JM-2 ) 

(  -AlP  +  ( 37. /32. )*A2P  -  (37./5.)*BlP 

) 

(  -AIM  +  ( 37 ./32 . ) *A2M  -  (37./5.)*BlM 

) 


*  Get  new  trial  value  for  k**2  * 

******  W  1 


K2NEW  -  K20LD  -  W ( JM ) * ( PHI PPR  -  PHIMPR)  /  PHI2 


RETURN 


Early  return 


600  CONTINUE 


DO  620  J  -  1,  JM 
W(J)  -  PHIM ( J ) 
620  CONTINUE 


DO  640  J  -  JM+1,  N 
W(J)  *  PHIP(J) 
640  CONTINUE 


700  K2NEW  -  l.E-20 

RETURN 

END 


nnnnooonnoooooonoonnoo 


subroutine  interp  (  n,  z,  x,  ni,  ztotal,  zi,  xi  ) 


Q**********************************************************  ^  * 

Title:  Interp 

Purpose:  Interpolate  function  x(z),  from  depth  z-0  to  z-zto*-al 

Input  parameters: 

N  Length  of  arrays  X  and  Z 

Z  Real*4  array  of  length  N 

X  Real*4  array  of  length  N 

NI  Length  of  desired  output  arrays  ZI  and  XI 

ZTOTAL  Total  depth  to  which  interpolated  output  is  desired 

Output  parameters: 

ZI  Regular  (Real*4)  interval  array,  ranging  from  0  to  ZTOTAL, 

of  length  NI 

XI  Interpolated  values  (Real*4  array  of  length  NI 


***** 
★ 
* 
* 
* 
* 
r  * 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 
* 


REAL  Z( 1  )  ,  X( 1  )  ,  ZI ( 1  )  ,  XI ( 1  ) 

DZ  -  ZTOTAL/(NI-l  ) 

J  =  1 

DO  50  I  -  1,  NI 

Z I ( I )  -  ( 1-1 ) *DZ 
40  CONTINUE 

IF  (  ZI(I)  .GE.  Z(J)  .AND.  ZI(I)  -LE.  Z(J+1))  THEN 
XI(I)  -  X(J)  +  ( X( J  +  l ) -X { J)  ) * ( ZI ( I  )-Z( J  )  ) 

1  /( Z ( J  +  1)-Z(J)  ) 

ELSE 

J  -  J  +  1 

IF  (  I.EQ.NI  .AND.  ABS { ZI ( I ) -Z ( J ) ) . LE . 0 . 01  )  THEN 
ZI(I)  -  Z(J) 

XI ( I )  -  X( J) 

RETURN 

ENDIF 

IF  (  J  .GT.  N  )  STOP  40 
GO  TO  40 
ENDIF 
50  CONTINUE 

RETURN 

END 


SUBROUTINE  INTRPL( IU,L,X,Y,N,U,V) 

r  * 

INTRPL  * 

* 

INTERPOLATION  OF  A  SINGLE  VALUED  FUNCTION.  * 

THIS  SUBROUTINE  INTERPOLATES,  FROM  VALUES  OF  THE  * 

FUNCTION  GIVEN  A  ORDINATES  OF  INPUT  DATA  POINTS  IN  * 

THE  X-Y  PLANE  AND  FOR  A  GIVEN  SET  OF  X-VALUES ( ABCI SSAS ) , * 
THE  VALUES  OF  A  SINGLE  VALUED  FUNCTION  Y-Y(X). 


C  PROGRAM 
C 

C  PURPOSE 

C 

C 

C 

C 

c 


* 
* 

C  AUTHOR  HIROSHI  AKIMA , U . S . DEPT  OF  COMMERCE , OFFICE  OF  * 

C  TELECOMMUNICATIONS,  INSTITUTE  OF  TELECOMMUNICATIONS  * 

C  SCIENCES,  BOULDER  COLO  * 

C  THIS  ALGORITHM  WAS  PUBLISHED  IN  COMM.  ACM.  15(10)  * 

C  OCT  1972  * 

C  ‘  * 

C  * 

c  * 

c  * 

C  INPUT  PARAMETERS  ARE  * 

C  IU  =  LOGICAL  UNIT  NUMBER  OF  STANDARD  OUTPUT  UNIT  * 

C  L  =  NUMBER  OF  INPUT  DATA  POINTS  * 

C  X  -  ARRAY  OF  DIMENSION  L  STORING  THE  X  VALUES  * 

C  ( ABCI SSAS )  OF  THE  DATA  POINTS  IN  ASCENDING  ORDER  * 

C  Y  -  ARRAY  OF  DIMENSION  L  STORING  THE  Y  VALUES  * 

C  (ORDINATES)  OF  THE  INPUT  DATA  POINTS  * 

C  N  -  NUMBER  OF  POINTS  AT  WHICH  INTERPOLATION  OF  THE  * 

C  Y  VALUES  (ORDINATE)  IS  DESIRED  * 

C  U  -  ARRAY  OF  DIMENSION  N  STORING  THE  X  VALUES  OF  THE  * 

C  DESIRED  POINTS.  * 

C  * 

C  OUTPUT  PARAMETERS  * 

C  V  -  ARRAY  OF  DIMENSION  N  WHERE  THE  INTERPOLATED  Y  * 

C  VALUES  ARE  STORED  * 

£*★★*★★**★*******★*★★★★★★★*★★★★*★★★★*★★★★★★★★★★★*★★*★***★*★**★***★*★★★*★★ 

DIMENSION  X( 1 ) , Y( 1 ) ,U( 1 ) ,V( 1 ) 

EQUIVALENCE  ( P0 , X3 ) , ( Q0 , Y3 ) , ( Q1 , T3 ) 

REAL  Ml , M2 , M3 , M4 , M5 

EQUIVALENCE  ( UK , DX ) , ( IMN , X2 , Al , Ml ) , ( IMX , X5 , A5 , M5 ) , 

1  ( J,SW,SA) , (Y2,W2,W4,Q2) , (Y5,W3,Q3) 


C  PRELIMINARY  PROCESSING  * 


10  L0  -  L 

LMl  -  L0-1 
LM2  -  LMl-1 
LP1  -  L0+1 
NO  -  N 

I F (  LM2  .LT.  0  )  GO  TO  90 
I F (  NO  .LE.  0  )  GO  TO  91 

DO  11  1-2, L0 


11 


c 

c 

c 


c 

c 

c 

20 


I F ( X ( I— 1 ) -X ( I ) ) 
CONTINUE 

IPV  *  0 


'5,96 


MAIN  DO  LOOP 


DO  80  K  *  1 , NO 
UK=U(K) 


*  ROUTINE  TO  LOCATE  DESIRED  POINT  * 


I F ( LM2  .EQ.  0)  GO  TO  27 
I F ( UK  .GE.  X ( L0 ) ) GO  TO  26 
I F ( UK  .LT.  X( 1 ) )  GO  TO  25 
IMN  -  2 
I MX  -  L0 


21 

I  =  ( IMN+IMX )/2 

IF (UK  .GT.  X ( I ) )  GO  TO  23 

22 

IMX  =  I 

GO  TO  24 

23 

IMN  =1+1 

24 

I F (  IMX  .GT.  IMN)  GO  TO  21 

25 

26 

27 


I  =  I  MX 
GO  TO  30 

1  =  1 

GO  TO  30 

I  -  LPl 
GO  TO  30 

1=2 


C 

C 

C 


CHECK  IF  I  -  IPV 


30 

C 

C 

C 

C 

C 


I F ( I  .EQ.  IPV)  GO  TO  70 
IPV  =  I 


*  ROUTINES  TO  PICK  UP  NECESSARY  X  * 

*  AND  Y  VALUES  AND  TO  ESTIMATE  THEM  * 

*  IF  NECESSARY  * 


IF(J.EQ.l)  J=2 
IF(J.EQ.LPl)  J=L0 


X3 

= 

X( J-l ) 

Y3 

- 

Y(J-l) 

X4 

> 

X(  J) 

Y4 

= 

Y(  J) 

A3 

m 

X4-X3 

M3 

- 

( Y4-Y3 )/A3 

I F ( LM2  .EQ.  0)  GO  TO  43 
I F  ( J  .EQ.  2)  GO  TO  41 


X2  - 

X( J-2  ) 

Y2  - 

Y ( J-2  ) 

A2  - 

X3-X2 

M2  - 

( Y3-Y2 )/A2 

I F  (  J 

.EQ.  L0)  GO  TO  42 

41 

X5  = 

X( J+l ) 

Y5  - 

Y( J+l  ) 

A4  - 

X5-X4 

M4  - 

( Y5-Y4 ) /A 4 

I F  ( J 

.EQ.  2)  M2-M3  +  M3  - 

GO  TC 

l  45 

42 

M4  - 

M3+M3-M2 

GO  TC 

i  45 

43 

M2  - 

M3 

45 

I F  ( J 

.LE.  3)  GO  TO  46 

Al  - 

X2-X( J-3 ) 

Ml  = 

( Y2-Y( J-3 ) ) /Al 

GO  TC 

l  47 

46 

Ml  » 

M2+M2-M3 

47 

I  F  (  J 

.GE.  LMl )  GO  TO  48 

A5  - 

X( J+2 )  -  X5 

M5  = 

( Y ( J+2 )  -  Y5)/A5 

GO  TC 

i  50 

48 

M5*M4+M4-M3 

M4 


C 

C 

c 


★**★★★★***★★★**★★*★*★★*★★★*★★★★* 
*  NUMERICAL  DIFFERENTIATION  * 


50  I F (  I  .EQ.  LPl )  GO  TO  52 

W2  -  ABS ( M4-M3 ) 

W3  -  ABS ( M2-M1 ) 

SW  *  W2+W3 

IF(SW  .NE.  0.0)  GO  TO  51 


W2  -  0.5 
W3  -  0.5 
SW  -  1.0 


51 


T3  «  (W2*M2+W3*M3 )/SW 
I F ( I  .EQ.  1)  GO  TO  54 


52  W3  -  ABS ( M5-M4 ) 

W4  -  ABS ( M3-M2 ) 

SW  «  W3+W4 

I F ( SW  .NE.  0.0)  GO  TO  53 


W3  -  0.5 
W4  -  0.5 
SW  -  1.0 


53  T4-(W3*M3+W4*M4 )/SW 

I F (  I  .NE.  LPl )  GO  TO  60 
T3  -  T4 
SA  -  A2  +  A3 


c 
c 
c 

90  WRITE ( IU , 2090 ) 

GO  TO  99 

91  WRITE( IU, 2091 ) 

GO  TO  99 

95  WRITE ( IU , 2  09  5 ) 

GO  TO  97 

96  WRITE( IU, 2096 ) 

97  WRITE( IU, 2097 )  I,X(I) 

99  WRITE ( IU, 2099 )  L0,N0 

RETURN 

*  2090  FORMAT ( IX , '  ***  L  -  1  OR  LESS'/) 

2091  FORMAT ( IX , '  ***  N  -  0  OR  LESS'/) 

■ 

2095  FORMAT ( IX , '  ***  IDENTICAL  X  VALUES'/) 

2096  FORMAT ( IX, '  ***  X  VALUES  OUT  OF  SEQUENCE'/) 

2097  FORMAT ( IX , '  I-' , 17 , 10X, 'X( I )  »',E12.3/) 

2099  FORMAT ( IX , '  I- ' , 17 , 10X, ' N  - ' , 17/ 

1  IX, ' ****ERROR  DETECTED  IN  ROUTINE  INTRPL******* '//) 


***************** 
*  ERROR  EXITS  * 


END 


noon  nnoonnnooonnoonnoonoonoonono 


FUNCTION  BVFRQ (  S  ,  T ,  P  , NOBS , PAV , E ) 

* 


PROGRAM  BVFRQ 

PURPOSE  COMPUTES  Brunt-Vaisala  frequency  in  CPH 

AUTHOR  R.  MILLARD,  WOODS  HOLE  OCEANOGRAPHIC  INSTITUTION 

NOTES: 


* 

* 

★ 

* 

★ 

* 

* 

A 


USES  1980  EQUATION  OF  STATE 


UNITS: 

PRESSURE  P0 

TEMPERATURE  T 

SALINITY  S 

BOUYANCY  FREQ  BVFRQ 
N*  *2  E 


DECIBARS 

DEG  CELSIUS  (IPTS-68) 
( IPSS-78  ) 

CPH 

RADIANS/SECOND 


CHECKVALUE:  BVFRQ-14 . 57836  CPH  E-6 . 4739928E-4  RAD/SEC. 
S(l)«35.0,  T( 1 ) -5 . 0 ,  P(l)-1000.0 
S(2)«35.0,  T(2)-4.0,  P(2)-1002.0 
******* *NOTE  RESULT  CENTERED  AT  PAV-1001.0  DEARS  ********** 
JULY  12  1982 

COMPUTES  N  IN  CYCLES  PER  HOUR,  AND  E-N**2  IN  RAD/SEC**2 
AFTER  FORMULATION  OF  BRECK  OWEN'S  &  N.P.  FOFONOFF 


* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 

* 


IMPLICIT  NONE 


1 


REAL *4 
REAL*4 

REAL*  4 
INTEGER*  4 
EXTERNAL 


P(1),T(1),S(1) 

E , BVFRQ , CXX , CX , CXY , C Y , PAV , DATA , V3  5  0  P , VBAR , 
S IG , DVDP , AO 

SVAN, THETA 

NOBS  ,  K 

SVAN, THETA 


E  -  0.0 
BVFRQ  -  0.0 

IF  (NOBS.LT.2)  RETURN 

CXX  -  0.0 
CX  -0.0 
CXY  -  0.0 
CY  -  0.0 

*  COMPUTE  LEAST  SQUARES  ESTIMATE  OF  SPECIFIC  * 

*  VOLUME  ANAMOLY  GRADIENT  * 

DO  20  K-l , NOBS 
CX  -CX+P ( K ) 

20  CONTINUE 

PAV-CX/NOBS 

DO  35  K-l, NOBS 

DATA  -  SVAN ( S ( K ) , THETA ( S{K),T(K),P(K), PAV ) , PAV ,SIG)*1 .OE-8 


nnonnooonnnn 


CXY  -  CXY+DATA* (  P  (  K  ) -PAV ) 

CY  -  CY+DATA 
CXX  -  CXX+( P( K)-PAV) **2 
35  CONTINUE 

IF(CXX.EQ.O.O)  RETURN 

AO  -  CXY/CXX 

V350P  -  (l./(SIG+1000. ) )-DATA 

VBAR  -  V350P+CY/NOBS 

DVDP  -  AO 

IF( VBAR. EQ. 0.0)  RETURN 

E  -  - . 96168423E-2*DVDP/( VBAR )  **2 

BVFRQ  -  572 . 9 578 * SIGN ( SQRT( ABS (  E  )  )  ,  E  ) 


RETURN 

END 


FUNCTION  GRADY( Y,P, NOBS, PAV, YBAR) 


TITLE:  GRADY  * 

* 

PURPOSE:  FUNCTION  COMPUTE  LEAST  SQUARES  SLOPE  'GRADY'  OF  Y  VERSUS  P  * 
THE  GRADIENT  IS  REPRESENTIVE  OF  THE  INTERVAL  CENTERED  AT  * 

PAV  * 

COMPUTE  GRADIENT  OF  Y  VERSUS  P  * 

* 

DATE:  JULY  15  1982  * 

* 

REAL* 4  P( 1 ) ,Y( 1 ) 

GRADY  -  0.0 
AO  *  0.0 
CXX  -  0.0 
CX  -  0.0 
CXY  -  0.0 
CY  -  0.0 

IF(NOBS.LE.l)  GO  TO  30 

DO  20  K-l , NOES 
20  CX  -CX+P(K) 

PAV  -  CX/NOBS 

DO  35  K-l, NOBS 

CXY  -  CXY+Y ( K ) *( P ( K ) -PAV ) 

CY  -  CY+Y ( K ) 

CXX-  CXX+ ( P ( K ) -PAV ) *  *  2 
35  CONTINUE 

I F ( CXX . EQ .0.0)  RETURN 

A0  -  CXY/CXX 
YBAR-  CY/NOBS 


30  CONTINUE 

GRADY-AO 

RETURN 

END 


OCEAN  SIMULATION  MODELING 


DISTRIBUTION: 

Naval  Oceanographic  and  Atmospheric  Research  Laboratory 
Stennis  Space  Center,  MS  39529-5004 

ATTN:  Code  110 

111 
113 

115  (Meert,  Lundberg,  Stanley,  Goggins,  Winchester) 
200 
220 

221  (Norton) 

224  (Campbell) 

240  (Farwell) 

242 

244  (Slater) 

245  (Wagstaff) 

250 

300 

310 

311  (Ferer,  Selsor) 

320 

321  (Pressman,  Holyer,  Mitchell,  Smith,  Lybanon) 

322  (Harding,  Preller,  Martin,  Carnes) 

323  (Heburn,  Blake,  Hurlburt,  Thompson,  Kindle) 

330 

331  (Hollman,  Teague,  Hallock,  Boyd,  Pickett,  Burns) 

332 

333 

350 

351  (Walker) 

352  (Mozley,  Arnone) 

360 

362 

125L  (10) 

125P 


NOARL 

Code  400  (Hovermale,  Tag,  Brand,  Haggerty) 

Monterey,  CA  93943-5006 

I  NO 

Attn:  (B.  Willems,  J.  Leese,  L.  Kantha,  E.  Johnson,  ) 

Naval  Ocean  Systems  Center 
Attn:  (J.  Richter  Code  17) 

San  Diego,  CA  92152 


Office  of  Naval  Technology 
Attn:  (CDR  L.  Bounds) 

(Dr.  M.  Brisco) 

(Dr.  C.  Votaw) 

(Dr.  P.  Selvyn) 

800  N.  Quincy  Street 
Arlington,  VA  22217-5000 

Office  of  Naval  Research 
Attn:  (Dr.  A.  Brand) 

(Dr.  A.  Weinstein) 

800  N.  Quincy  Street 
Arlington,  VA  22217-5000 

Space  and  Naval  Warfare  Systems  Command 
Attn:  Code  315,  312,  PD  80 

Washington,  DC  20363-5000 

Naval  Underwater  Systems  Center 
Attn:  J.  Keil,  Code  60 

Newport,  RI  02841-5047 

Naval  Coastal  Systems  Center 
Attn:  D.  Sheppard,  Code  10 

Panama  City,  FL  32407-5000 

Naval  Air  Development  Center 
Attn:  R.  Becker,  Code  30 
Warminister,  PA  18974 

Naval  Weapons  Center 
Attn:  P.  Arnold,  Code  30 

China  Lake,  CA  93555-6001 

Naval  Surface  Weapons  Center 
Attn:  A.  Glazman,  Code  D25 
White  Oak 

Silver  Spring,  MD  20910 

David  W.  Taylor  Naval  Research  Center 
Attn:  S.  Goldstein  Code  1203 
Bethesda,  MD  20084-5000 

Oceanographer  of  the  Navy 

Chief  of  Naval  Operations 

Attn:  OP-096  (R.  Winokur,  ADM  Pittenger) 

U.S.  Naval  Observatory 

34th  &  Mass  Ave,  NW 

Washington,  DC  20392-5100 


Chief  of  Naval  Operations 
Department  of  the  Navy 
Attn:  0P21T 
OP21T2 

Washington,  DC  20350-2000 

Center  for  Naval  Analyses 
Attn:  (R.  Bronowitz) 

4401  Ford  Avenue 
Alexandria,  VA  22302 

Superintendent 

Naval  Postgraduate  School 

Monterey,  CA  93943 

Commander,  Navy  Sea  Systems  Command 
Naval  Sea  Sys  Com  Headquarters 
Washington,  DC  20362-5101 

Commander 

Naval  Air  Systems  Command 
Naval  Air  Sys  Com  Headquarters 
Washington,  DC  20361-0001 

Asst  Secretary  of  the  Navy 
(Research,  Engineering  &  Systems) 
Navy  Dept 

Washington,  DC  20350-2000 

John  Hopkins  University 
Applied  Physics  Laboratory 
John  Hopkins  Road 
Laurel,  MD  20707 

SAIC 

Attn:  (Dr.  D.  Rubens te in) 

P.0.  BOX  1303 
1710  Goodridge  Dr. 

McLean,  VA  22102 

Sverdrup  Technology 
Attn:  (Dr.  Ransford) 

Stennis  Space  Center,  MS  39529 

Admiralty  Research  Establishment 
Attn:  (Dr.  John  Scott) 

Southwell,  Portland 
Dorset  DT5-2JS 
United  Kingdom 

SACLANT  Research  Center 
Attn:  (Dr.  Henry  T.  Perkins) 

400  Via  San  Bartolomeo 
19026  La  Spezia,  Italy 


Oregon  State  University 
Attn:  (Dr.  Robert  Miller) 
College  of  Oceanography 
Oceanography  Admin.  Bldg. 
Corvallis,  OR  97331 


REPORT  DOCUMENTATION  PAGE 


Form  Approved 
OBMNo.  0704-0 169 


1 


PutoUc  reporting  button  for  this  ooftoction  of  Informalion  b  to  cvorago  1  boor  p*r  roaponoa,  including  tha  tima  for  raviawfng  ln*ructi©nt,  Marching  axwting  data  aourcat, 

gafhadng  and  maintaining  (ha  naadad,  and  competing  and  ra»fawfng  tha  coiiaction  of  information.  Sand  commanta  regarding  m*  burdan  or  any  othar  aapact  of  this  coiiaction  of  Information , 

including  suggaabona  for  reducing  thia  burdan,  to  Washington  Headquarters  Service*,  Oirectoreta  for  information  Operations  and  Reports,  1213  Jefferson  Oavfa  Higheaiy,  SuNa  1 204,  Artingion, 
VA  22202-4302.  and  to  the  Office  of  Management  and  Budget.  Paper*©*  Reduction  Pmject  (0704-0166).  Washington,  DC  20503. 

1 .  Agency  Use  Only  (Leave  blank). 

Z  Report  Oat*.  3.  Raport  Typa  and  Dates  Covered. 

July  1990 

4.  Tide  end  Subtitle. 

Ocean  Simulation  Model  for  Internal  Waves 

ComDuter  Source  Code 

5.  Funding  Numbora. 

Pmgnvn  Etorrmt  Ho,  0602435N 

Prefer  Wa  03590 

TmkNa  OMOG 

DN258014 

&  Author(s). 

K.  D.  Saunders.  S.  A  Briggs  and  D.  Rubenstein* 

7.  Performing  Organization  Nsmss(t)  and  Addreee(ee). 

Naval  Oceanographic  and  Atmospheric  Research  Laboratory 

Ocean  Science  Directorate 

Stennis  Space  Center,  Mississippi  39529-5004 

8.  Performing  Organization 

Report  Number. 

NOARL  Technical  Note  59 

9.  Sponsoring/ Monitoring  Agency  Name<*)  and  Addreu(et). 

Naval  Oceanographic  and  Atmospheric  Research  Laboratory 

Requirements  and  Assessment  Office 

Stennis  Space  Center,  Mississippi  39529-5004 

10.  Sponsoring  /  Monitoring  Agency 

Report  Number. 

NOARL  Technical  Note  59 

11.  Supplementary  Notes. 

•Science  Applications  International  Corporation,  McLean  Virginia 

12a.  DIstribution/AvaiUbIBty  Statement 

Approved  for  public  release;  distribution  Is  unlimited. 

12b.  attribution  Code. 

1 X  Abstract  (Maximum  200  words). 

■ This  technical  note  contains  the  source  code  for  the  first  level  ocean  simulation  model  and  associated  test 
and  display  programs.  This  model  provides  simulations  of  internal  wave  activity  based  on  average  ocean¬ 
ographic  conditions  at  a  given  location.  The  code  is  written  in  FORTRAN  77  and  should  be  easily  ported 
to  a  wide  variety  of  computers  and  operating  systems.  This  technical  note  Is  intended  primarily  for  persons 
implementing  and/or  modifying  the  code  on  their  own  systems.  1/  <•  >  't  j  • 

14.  Subject  Terms. 

QJ’f  dynamicaf  oceanography;  (UJ  physical  oceanography,  (U)  ocean  simulation  * 

(U)f«»odefing.  /  ■  c  v<  .  -  .  '• •'  ' 

15.  Number  of  Pagoa. 

156 

16.  PrteoCodo. 

17.  Security  Classfflcation 
of  Report 

Unclassified 

18.  Security  Classification  19.  Security  Oaasiftcalion 

of  Thle  Pago.  of  Abafract 

Unclassified  Unclassified 

20.  limitation  of  Abstract 

SAR 

MSN  7&40-01 -2006600 


Standard  Form  296  (Pm,  2-60) 
Prwcribad  by  ANSI  Sd.  230-10 
296-102 


